home *** CD-ROM | disk | FTP | other *** search
/ Aminet 52 / Aminet 52 (2002)(GTI - Schatztruhe)[!][Dec 2002].iso / Aminet / misc / emu / Apex-src.lha / XPL.XPL < prev    next >
Text File  |  2001-09-30  |  63KB  |  2,274 lines
  1. \XPL.XPL    APR-24-87
  2. \XPL0 compiler for the 68000.
  3. \Copyright 1977-1987 P.J.R. Boyle
  4. \
  5. \To convert to integer only, look for "$$$"
  6. \
  7. \REVISION HISTORY:
  8. \1981, Added floating point, Loren Blaney
  9. \JAN-85, Modified to produce 68000 op codes, L.B.
  10. \DEC-85, Modified to produce 68881 op codes, L.B. & R.O.
  11. \FEB-86, Modified for 32-bit operation for DFM Engineering, L.B.
  12. \AUG-OCT-86, Fixed miscellaneous bugs, modified for new INT.68K, and
  13. \ added register variables.
  14. \DEC-09-86, Fixed module stuff
  15. \MAR-87, V5.7, 32-bit MUL & DIV, added shift and EOR ops. Fixed undetected
  16. \ mixed-mode error (for & !), and fixed passing more than 5 arguments.
  17. \APR-87, Fixed global register variables, .OBJ buffer, and spring cleaning.
  18. \ Changed string termination convention. Fixed stack balancing bug in 'IF'
  19. \ expressions, $80000000 bug, hex overflow detection, and negative def bug.
  20. \ Added a number of optimizations.
  21. \
  22. \CONTENTS:
  23. \ MAIN: Display title and initialize
  24. \    ERROR: Display error message and optionally continue
  25. \    GETCH: Get a character from the source device
  26. \    RATOM: Read an atom from source device
  27. \    HEX2OUT: Output a hex byte (in ASCII) to disk
  28. \    GEN: Output 68000 code to disk
  29. \    FIXUP: Set contents of specified location to the current PC
  30. \    LOOKUP: Look up an identifier name in the symbol table
  31. \    INSERT: Insert an identifier into the symbol table
  32. \    GETCON: Get a constant
  33. \    PROCAL: Procedure calls
  34. \    BOOLEXP: Generate code for a boolean expression
  35. \        FACTOR: Generate code for a factor
  36. \            STRCON: Text string constant ("string")
  37. \            ARRAYCON: Constant array
  38. \            SPECFAC: Special factors ('ADDR', string)
  39. \            IDFAC: Identifier factors
  40. \        SHIFTEXP: Generate code for a shift (e.g: A<<B)
  41. \        TERM: Generate code for a term (e.g: A*B)
  42. \        ALGEXP: Algebraic expression (e.g: A+B)
  43. \        LOGEXP: Logical expression (e.g: A=B)
  44. \        BOOLTERM: Boolean term (e.g: A&B)
  45. \    SSTATEMENT: (for 'QUIT'S in 'CASE' statements)
  46. \        STATEMENT: Parse and generate code
  47. \            ASSIGN: Assignment statements
  48. \            CASER: Case statements
  49. \    PROCEDURE: Parse and generate code
  50. \        CODDEC: 'CODE' declaration
  51. \        CONDEC: 'DEFINE' declaration
  52. \        VARDEC: 'INT','REAL', and 'ADDR' declarations
  53. \        RVARDEC: 'REG' 'INT' declarations
  54. \        EXTDEC: 'EXTERNAL' procedure declaration
  55. \        FPRDEC: Forward PROCEDURE DECLARATIONS
  56. \        EPRDEC: External procedure declarations
  57. \        PROCDEC: 'PROCEDURE' declarations
  58.  
  59. code    ABS= 0        RESERVE= 3    SWAP= 4        CHIN= 7
  60.     CHOUT= 8    CRLF= 9        INTIN= 10    INTOUT= 11
  61.     TEXT= 12    OPENI= 13    OPENO= 14    CLOSE= 15
  62.     SWAPWD= 117;
  63. code real FLOAT= 49,    RLRES= 46;
  64.  
  65. ext    CHIN3= $C00, CHOUT3= $C06;
  66.  
  67. def    TV= 0, KB= 0;    \Device numbers
  68. def    TAB= $09, EOF= $1A, BEL= $07, EOL= $0D, SPACE= $20;     \ASCII chars
  69. def    INTTBL= $800,    \Address of intrinsic jump table
  70.     MUL1= $B04,    \Base address of 32-bit multiply routines
  71.     DIV1= $B28,    \Base address of 32-bit divide routines
  72.     VEXIT= $40C,    \Address of exit vector for 'EXIT' statement
  73.     SYMAX= 1000    \Size of the symbol table
  74.     RLMAX= 100    \Size of real-constant symbol table
  75.     INTSIZE= 4    \No. of bytes in an integer (other changes required)
  76.     RLSIZE= 8    \No. of bytes in a real number (must be even)
  77.             \WARNING: TRI, TRA, & TRX must agree in size
  78.     SIGCHAR= 8    \No. of significant chars in an IDENT
  79.     QUITMAX= 100;    \Maximum no. of 'QUIT'S in a 'LOOP'
  80.  
  81. addr    ERRBUF;        \Listing buffer for error messages
  82.  
  83. reg int    DSP;        \Data register number (pseudo stack pointer)
  84. reg int    CHAR;        \Current character.  Most of the time it
  85.             \ contains the terminator of the current ATOM
  86. reg int    ERRPTR;        \Pointer for ERRBUF
  87.  
  88. int    OBJBUF        \.OBJ buffer (FIFO), compresses .OBJ file 20%
  89.     OBJFILL        \Fill index
  90.     OBJEMPTY;    \Empty index
  91.  
  92. int    FPSP        \Floating point register number
  93.     PSTOP        \Greatest register (+1) in pseudo stack
  94.             \ This also points to the base of register variables
  95.     PSTOP0        \PSTOP when first entering procedure (for HPI & RET)
  96.     FPSTOP        \Greatest register (+1) in FP pseudo stack
  97.             \ Also points to the base of real register variables
  98.     ERRCNT        \Error counter
  99.     DEFAULT        \Default options array.  WARNING!  not rommable
  100.     LSTDEV        \Listing output device number
  101. \    CASEIN        \\Boolean: upper/lower case for (')
  102.     ATOM        \Present atom descriptor
  103.             \ Contains reserved word hash or the ASCII for a
  104.             \ special character. Contains  0 if the atom is a
  105.             \ constant or an identifier
  106.     ATYPE;        \Present ATOM type descriptor
  107. def    \ATYPE\ SPECIAL, IDENTIFIER, INTCON, REALCON;
  108. addr    IDENT;        \Array: current identifier name
  109. int    HASH        \Current identifier hash code
  110.     IATOM;        \Value of current integer constant
  111. real    RLATOM;        \Real constant from procedure "RATOM"
  112.  
  113. int    IDTYPE;        \Present identifier type descriptor (order is critical)
  114. def    UNDEF= 0    \Undefined identifier
  115.     ADDRVAR= 1    \Address variable ID (IDTYPE = INTEGER)
  116.     INVAR= 3    \Integer variable ID (odd nos.= INTEGER)
  117.     RLVAR= 4    \Real variable ID
  118.     INCON= 5    \Integer constant ID
  119.     RLCON= 6    \Real constant ID
  120.     INPROC= 7    \Integer procedure ID
  121.     RLPROC= 8    \Real procedure ID
  122.     INEPROC= 9    \Integer external procedure ID
  123.     RLEPROC= 10    \Real external procedure ID
  124.     INFPROC= 11    \Integer forward procedure ID
  125.     RLFPROC= 12    \Real forward procedure ID
  126.     ININT= 15    \Integer intrinsic ID
  127.     RLINT= 16    \Real intrinsic ID
  128.     INEXT= 17    \Integer external procedure ID
  129.     RLEXT= 18;    \Real external procedure ID
  130.  
  131. int    LEV        \Level (static) of current identifier
  132.     VAL        \Value or address of current identifier
  133.     SYMNUM        \Position in SYMTBL of current identifer
  134.     FACTYP;        \Factor (or operand) type (INTEGER or REAL)
  135. def    \FACTYP\ INTEGER, REAL;
  136. int    FIXES        \Array: 'QUIT' fixes still outstanding
  137.     PC        \Program counter
  138.     LASTOP        \Previous opcode used by GEN
  139.     LASTLEV        \Previous level used by GEN
  140.     LASTVAL        \Previous value used by GEN
  141.     LEVEL        \Level (static) of current procedure
  142.     NOSYM        \Current number of symbols in symbol table
  143.     FIXCNT        \Count of the number of outstanding 'QUIT'S
  144.     STKLOD        \No. of integers left on stack by 'FOR' or 'CASE'
  145.     NORLSY        \Current number of real constants in table
  146.     II;        \Scratch
  147. addr    HEXDIGIT;     \Array of hex digits (0 - F)
  148.  
  149. \SYMBOL TABLE ARRAYS:
  150. addr    SYMBOL        \Identifier name (IDENT)
  151.     SYMTYP;        \Type descriptors (IDTYPE)
  152. int    SYMVAL;        \Value or address (VAL)
  153. addr    SYMLEV;        \Level (LEV)
  154. int    SYMPNT;        \List linkage pointers
  155. int    BOXES;        \Hash boxes (symbol list headers)
  156. real    RLTBL;        \Real constant table
  157.  
  158. \RESERVED WORD HASHES:
  159. def    ADRSYM= 25797    BEGSYM= 26057    CASEYM= 25046    CODSYM= 28615
  160.     DEFSYM= 26058    DOSYM=  28516    ELSEYM= 27864    ENDSYM= 28361
  161.     EXITYM= 30926    EXTNYM= 30937    FALSYM= 25042    FFUNYM= 26331
  162.     FORSYM= 28632    FPRSYM= 28888    FUNSYM= 30164    GESYM=  25959
  163.     GETSYM= 26075    IFSYM=  26217    INTSYM= 28381    LESYM=  25964
  164.     LOOPYM= 28635    NOTSYM= 28642    OFSYM=  26223    PROCYM= 29407
  165.     QUITYM= 30170    REALYM= 26067    REPSYM= 26082    RETSYM= 26086
  166.     THENYM= 26841    TRUSYM= 29417    UNTSYM= 28393    WHILYM= 26848
  167.     EPRSYM= 28887    EFUNYM= 26330    LNKSYM= 27098    OTHSYM= 29911
  168.     REGSYM= 26073    LSLSYM= 29656,    LSRSYM= 29662;
  169.  
  170.  
  171.  
  172. proc    ERROR(ERRNO);    \Send error message to the TV
  173. int    ERRNO;
  174. int    ERR, CH, I;
  175. addr    STRING;
  176. def    MAXERR= 68;    \Maximum error number
  177. begin
  178. if LSTDEV # TV then
  179.     begin
  180.     TEXT(TV,"
  181.  
  182. . . . ");
  183.     for I:= 0,$FF do            \Display last 256 characters
  184.         begin
  185.         CH:= ERRBUF(ERRPTR);
  186.         if CH#0 then CHOUT(TV,CH);
  187.         ERRPTR:= (ERRPTR+1) & $FF;    \Bump circular pointer
  188.         end;
  189.     end;
  190.  
  191. ERR:= RESERVE((MAXERR+1) *INTSIZE);
  192. for I:= 0, MAXERR do ERR(I):= "?";    \Unused error nos. = "?"
  193.  
  194. ERR(0):= "I'M VERY CONFUSED";        \Internal error
  195. ERR(1):= "TOO MANY VARIABLES";
  196. ERR(2):= "TOO MANY REAL CONSTANT NAMES";
  197. ERR(3):= "TOO MANY NAMES";
  198. ERR(4):= "TOO MANY 'QUITS'";
  199. ERR(5):= "TOO MANY STATIC LEVELS";
  200. ERR(6):= "NUMBER OUT OF RANGE";
  201. ERR(7):= ERR(6);            \For intrinsic declarations
  202. ERR(8):= "TOO MANY REGISTER VARIABLES";
  203. ERR(10):= "UNDECLARED NAME";
  204. ERR(11):= "NAME ALREADY DECLARED";
  205. ERR(20):= "ILLEGAL START OF A STATEMENT";    \In ASSIGN
  206. ERR(21):= "^":=^"*";
  207. ERR(22):= "'THEN'*";
  208. ERR(23):= "'DO'*";
  209. ERR(24):= "^",^"*";
  210. ERR(26):= "ILLEGAL FACTOR";        \Unrecognizable special factor
  211. ERR(27):= "STATEMENT STARTING WITH A CONSTANT";    \In ASSIGN
  212. ERR(28):= "'UNTIL'*";
  213. ERR(29):= "'OTHER'*";
  214. ERR(30):= "'ELSE'*";
  215. ERR(31):= "DIGIT*";
  216. ERR(33):= "INTEGER VARIABLE*";        \In a 'FOR' statement
  217. ERR(40):= "^"=^"*";
  218. ERR(41):= "^";^"*";
  219. ERR(42):= "CONSTANT*";            \In GETCON
  220. ERR(43):= "VARIABLE*";            \For an 'ADDR' operator
  221. ERR(44):= "^")^"*";
  222. ERR(45):= "NAME*";
  223. ERR(46):= "MIXED MODE";
  224. ERR(47):= "INTEGER*";
  225. ERR(48):= "'OF'*";
  226. ERR(49):= "^":^"*";
  227. ERR(50):= "^"]^"*";
  228. ERR(52):= "STATEMENT STARTING WITH 'ELSE'";
  229. ERR(53):= "STATEMENT STARTING WITH 'OTHER'";
  230. ERR(55):= "VARIABLE DECLARATION*";
  231. ERR(60):= "'QUIT' NOT IN A 'LOOP'";
  232. ERR(61):= "EOF*";
  233. ERR(62):= "EOF INSIDE A BLOCK";
  234. ERR(63):= "EOF INSIDE A STRING";
  235. ERR(65):= "'FPROC' & ITS 'PROC' NOT AT SAME LEVEL";
  236. ERR(66):= "'FPROC' REFERENCE NOT FOUND";
  237. ERR(67):= "'PROC' OR 'FUNC'*";
  238. ERR(68):= "'EPROC'S AND 'LINK'S MUST BE GLOBAL";
  239.  
  240. CHOUT(TV,BEL);
  241. TEXT(TV,"
  242. ***** ERROR NO. "); INTOUT(TV,ERRNO); TEXT(TV," *****
  243. ");
  244. STRING:= ERR(ERRNO);
  245. I:= 0;
  246. loop    [CH:= STRING(I);        \Output message
  247.     if CH = 0 then quit;
  248.     if CH = ^* then TEXT(TV," EXPECTED BUT NOT FOUND")
  249.         else CHOUT(TV,CH);
  250.     I:= I +1];
  251. CRLF(TV);
  252. TEXT(TV,"ATTEMPT TO CONTINUE (Y/N)? ");
  253. OPENI(KB);
  254. if CHIN(KB) = ^N then [CLOSE(LSTDEV); exit];
  255. ERRCNT:= ERRCNT +1;
  256. end;    \ERROR
  257.  
  258.  
  259.  
  260. proc    LIST(CH);    \Save the last 256 characters in case of an error
  261. int    CH;
  262. begin
  263. ERRBUF(ERRPTR):= CH;
  264. ERRPTR:= (ERRPTR+1) & $FF;
  265. if LSTDEV # 7 then CHOUT(LSTDEV,CH);    \Fast filter if null device
  266. end;    \LIST
  267.  
  268.  
  269.  
  270. proc    GETCH;        \Get a character from the disk
  271. \Filters out comments and does case shift.
  272. \(This procedure is optimized for speed.)
  273. begin
  274. CHAR:= CHIN3;
  275. ERRBUF(ERRPTR):= CHAR;    \Save the last 256 characters in case of an error
  276. ERRPTR:= (ERRPTR+1) & $FF;
  277. if 7 # LSTDEV then CHOUT(LSTDEV,CHAR);    \Fast filter if null device
  278.  
  279. while ^\ = CHAR do            \Filter out comments
  280.     begin
  281.     loop    begin
  282.         CHAR:= CHIN3;
  283.         ERRBUF(ERRPTR):= CHAR;
  284.         ERRPTR:= (ERRPTR+1) & $FF;
  285.         if 7 # LSTDEV then CHOUT(LSTDEV, CHAR);
  286.  
  287.         case CHAR of
  288.           EOL:    quit;
  289.           ^\:    quit;
  290.           EOF:    return        \Don't filter out EOF's
  291.         other;
  292.         end;
  293.  
  294.     CHAR:= CHIN3;            \Get first character after comment
  295.     ERRBUF(ERRPTR):= CHAR;
  296.     ERRPTR:= (ERRPTR+1) & $FF;
  297.     if 7 # LSTDEV then CHOUT(LSTDEV, CHAR);
  298.     end;
  299.  
  300. \The compiler runs 2.5% faster if the case shift is not used
  301. \if CHAR = ^' then [CASEIN:= ~CASEIN; CHAR:= SPACE]    \\Shift case
  302. \else if CASEIN then        \\Switch to lower case if CASEIN is true
  303. \    [if CHAR>=^A & CHAR<=^Z then CHAR:= CHAR+32];
  304. end;    \GETCH
  305.  
  306.  
  307.  
  308. proc    RATOM;        \Read an atom
  309. \Outputs:  ATOM, ATYPE, IDENT, HASH, IATOM, CHAR, RLATOM.
  310. \ (This procedure is optimized for speed.)
  311. int    LEN, I, NEG, EXP;
  312. real    FRACT, DENOM;
  313.  
  314.     proc    RFRACT;        \Read the fractional part of a real no.
  315.     begin
  316.     ATYPE:= REALCON; ATOM:= 0;
  317.     GETCH;
  318.     FRACT:= FLOAT(0); DENOM:= FLOAT(10);    \(10.0 is not as portable)
  319.     while CHAR>=^0 & CHAR<=^9 do
  320.         [FRACT:= FRACT +FLOAT(CHAR-^0) /DENOM;
  321.         DENOM:= DENOM *FLOAT(10);
  322.         GETCH];
  323.     RLATOM:= RLATOM +FRACT;
  324.     end;    \RFRACT
  325.  
  326.  
  327.  
  328.     proc    REXP;        \Read an exponent, if any
  329.     if CHAR=^E then
  330.         begin
  331.         ATYPE:= REALCON;
  332.         GETCH;
  333.         if CHAR=^- then [NEG:= true; GETCH]
  334.             else NEG:= false;
  335.         if CHAR=^+ then GETCH;
  336.         EXP:= 0;
  337.         if CHAR<^0 ! CHAR>^9 then ERROR(31);
  338.         while CHAR>=^0 & CHAR<=^9 do
  339.             [EXP:= EXP *10 +CHAR-^0; GETCH];
  340.         if NEG then EXP:= -EXP;
  341.         while EXP>0 do
  342.             [RLATOM:= RLATOM *FLOAT(10); EXP:= EXP-1];
  343.         while EXP<0 do
  344.             [RLATOM:= RLATOM /FLOAT(10); EXP:= EXP+1];
  345.         end;    \REXP
  346.  
  347. begin    \RATOM
  348. while $20 >= CHAR \space\ do
  349.     begin    \Skip spaces, tabs, returns, LF's, & FF's, etc.
  350.         \Don't go past EOF
  351.     if EOF = CHAR then [ATYPE:= SPECIAL; ATOM:= EOF; return];
  352.     GETCH;
  353.     end;
  354. if ^a <= CHAR then if CHAR <= ^z then        \RESERVED WORD
  355.     [ATYPE:= SPECIAL;
  356.     ATOM:= CHAR; GETCH;
  357.     ATOM:= ATOM +SWAP(CHAR); GETCH;
  358.     if CHAR>=^a & CHAR<=^z then [ATOM:= ATOM+CHAR; GETCH];
  359.     while ^a<=CHAR & CHAR<=^z do GETCH;
  360.     if ATOM=TRUSYM then
  361.         [ATYPE:= INTCON; ATOM:= 0; IATOM:= true; return];
  362.     if ATOM=FALSYM then
  363.         [ATYPE:= INTCON; ATOM:= 0; IATOM:= false];
  364.     return];
  365. if ^A <= CHAR then if CHAR <= ^Z then        \IDENTIFIER
  366.     begin
  367.     ATYPE:= IDENTIFIER; ATOM:= 0;
  368.     IDENT(0):= CHAR; HASH:= CHAR; GETCH;
  369.     LEN:= 1;
  370.     loop case of
  371.       ^A<=CHAR & ^Z>=CHAR,  CHAR>=^0 & CHAR<=^9,  CHAR=^_ :
  372.         begin
  373.         if SIGCHAR > LEN then
  374.             [IDENT(LEN):= CHAR;
  375.             HASH:= HASH +CHAR;
  376.             LEN:= LEN +1];
  377.         GETCH;
  378.         end
  379.     other quit;
  380.     for LEN:= LEN, SIGCHAR-1 do
  381.         [IDENT(LEN):= SPACE; HASH:= HASH +SPACE];
  382.     HASH:= HASH & $FF;
  383.     return;
  384.     end;
  385. if ^0 <= CHAR then if CHAR <= ^9 then        \UNSIGNED INTEGER
  386.     begin
  387.     ATYPE:= INTCON;            \Assume integer until shown otherwise
  388.     ATOM:= 0;
  389.     IATOM:= CHAR -^0; GETCH;
  390.     loop    begin
  391.         I:= IATOM;
  392.         if CHAR<^0 ! CHAR>^9 then quit;
  393.         I:= IATOM *10 + CHAR-^0;
  394.         if I<0 \integer overflow\ then quit;
  395.         IATOM:= I;
  396.         GETCH;
  397.         end;
  398. \Remove the following line for integer-only version of the compiler $$$
  399. \    RLATOM:= FLOAT(IATOM);                \\*** DEBUG ***
  400.     IATOM:= I;            \(can't FLOAT($80000000))
  401.     while CHAR>=^0 & CHAR<=^9 do    \More digits; must be real
  402.         [RLATOM:= RLATOM *FLOAT(10) + FLOAT(CHAR-^0);
  403.         GETCH];
  404.     if CHAR=^. then RFRACT;            \UNSIGNED REAL
  405.     REXP;
  406.     if ATYPE=INTCON & IATOM<0 & IATOM#$80000000 then ERROR(6);
  407.     return;
  408.     end;
  409. case CHAR of
  410.   ^.:    [RLATOM:= FLOAT(0);            \UNSIGNED REAL
  411.     RFRACT;
  412.     REXP;
  413.     return];
  414.   ^$:    begin                    \UNSIGNED HEX INTEGER
  415.     ATYPE:= INTCON; ATOM:= 0;
  416.     GETCH;
  417.     case of
  418.     CHAR>=^0 & CHAR<=^9: IATOM:= CHAR-^0;
  419.     CHAR>=^A & CHAR<=^F: IATOM:= CHAR-$37
  420.     other [\DIGIT EXPECTED\ ERROR(31); return];
  421.     loop    [GETCH;
  422.         case of
  423.         CHAR>=^0 & CHAR<=^9: I:= CHAR-^0;
  424.         CHAR>=^A & CHAR<=^F: I:= CHAR-$37
  425.         other return;
  426.         if IATOM & $F0000000 then ERROR(6);
  427.         IATOM:= IATOM <<4 + I];
  428.     end;
  429.   ^^:    [ATYPE:= INTCON;            \META CHARACTER
  430.     ATOM:= 0;
  431.     CHAR:= CHIN3;
  432.     LIST(CHAR);
  433.     IATOM:= CHAR;
  434.     GETCH;
  435.     return];
  436.   ^":    [ATYPE:= SPECIAL;            \SPECIAL CHARACTER
  437.     ATOM:= CHAR;        \(' and backslash have no effect in strings)
  438.     CHAR:= CHIN3;
  439.     LIST(CHAR);
  440.     return]
  441. other;
  442. ATYPE:= SPECIAL;                \SPECIAL CHARACTER
  443. ATOM:= CHAR;
  444. GETCH;
  445. case CHAR of
  446.   ^=:    case ATOM of
  447.       ^::    [GETCH; ATOM:= GETSYM];
  448.       ^>:    [GETCH; ATOM:= GESYM];
  449.       ^<:    [GETCH; ATOM:= LESYM]
  450.     other;
  451.   ^<:    [if ATOM = ^< then [GETCH; ATOM:= LSLSYM]];
  452.   ^>:    [if ATOM = ^> then [GETCH; ATOM:= LSRSYM]]
  453. other;
  454. end;    \RATOM
  455.  
  456.  
  457.  
  458. proc    SKIPIT;        \Skip the rest of a statement for error recovery
  459. begin
  460. while ATOM#EOF & ATOM#^; & ATOM#ENDSYM & ATOM#^] &
  461.     ATOM#BEGSYM & ATOM#^[ do RATOM;
  462. end;    \SKIPIT
  463.  
  464. \----------------------------------------------------------------------
  465.  
  466. proc    HEX2OUT(VAL);    \Output a hex byte
  467. reg int    VAL;
  468. begin
  469. CHOUT3(HEXDIGIT(VAL>>4 & $0F));
  470. CHOUT3(HEXDIGIT(VAL & $0F));
  471. end;    \HEX2OUT
  472.  
  473.  
  474.  
  475. proc    HEX4OUT(VAL);    \Output a 4-digit hex word to the disk
  476. reg int    VAL;        \(Optimized for speed)
  477. reg addr HD;
  478. begin
  479. HD:= HEXDIGIT;
  480. CHOUT3(HD(VAL>>12 & $0F));
  481. CHOUT3(HD(VAL>>8 & $0F));
  482. CHOUT3(HD(VAL>>4 & $0F));
  483. CHOUT3(HD(VAL & $0F));
  484. end;    \HEX4OUT
  485.  
  486.  
  487.  
  488. proc    OPENOBJ;    \Initialize OBJBUF pointers
  489. begin
  490. OBJFILL:= 0;
  491. OBJEMPTY:= 0;
  492. end;    \OPENOBJ
  493.  
  494.  
  495.  
  496. proc    CLOSEOBJ;    \Dump remaining words in OBJBUF to disk
  497. begin
  498. while OBJEMPTY # OBJFILL do
  499.     [HEX4OUT(OBJBUF(OBJEMPTY));
  500.     OBJEMPTY:= (OBJEMPTY +1) &7];
  501. end;    \CLOSEOBJ
  502.  
  503.  
  504.  
  505. proc    GENOP(OP);    \Output the opcode value
  506. int    OP;
  507. begin
  508. OBJBUF(OBJFILL):= OP;
  509. OBJFILL:= (OBJFILL +1) &7;
  510. if OBJFILL = OBJEMPTY then
  511.     [HEX4OUT(OBJBUF(OBJEMPTY));
  512.     OBJEMPTY:= (OBJEMPTY +1) &7];
  513. PC:= PC +2;
  514. end;    \GENOP
  515.  
  516.  
  517.  
  518. proc    GENPC(DELTA);    \Output new PC value, changed by DELTA
  519. int    DELTA;        \Number of bytes, (must be negative, even value)
  520. begin
  521. PC:= PC +DELTA;
  522. DELTA:= -DELTA >>1;            \Convert -bytes to +words
  523.  
  524. if DELTA > ((OBJFILL -OBJEMPTY) &7) then ERROR(0);
  525.  
  526. OBJFILL:= (OBJFILL -DELTA) &7;
  527. end;    \GENPC
  528.  
  529. \======================================================================
  530.  
  531. proc    GEN(OP, LEV, VAL, CL);    \Generate opcode
  532. int    OP,        \I2L-style opcode ($00..$3F)
  533.     LEV,        \Static nesting level, if memory access required
  534.     VAL,        \If memory access, offset from frame pointer
  535.             \ neg values are for register vars (-8 = D7, etc)
  536.     CL;        \Distinguish relocated immediates from constants
  537. int    I, MASK, PTR;
  538. addr    A;
  539.  
  540.  
  541.  
  542. proc    ONEOP(OP);    \Output a one-register opcode
  543. int    OP;
  544. begin
  545. GENOP(OP + DSP-1);
  546. end;    \ONEOP
  547.  
  548.  
  549.  
  550. proc    SRCOFF(OP);    \Generate a source effective-address code
  551. int    OP;        \ e.g: MOVE.L 4(A0),D1
  552. begin
  553. case of
  554.  VAL>0:    [GENOP(OP + $28 + LEV);        \off(Alev)
  555.     GENOP(VAL)];
  556.  VAL=0:    GENOP(OP + $10 + LEV);        \(Alev)
  557.  VAL<0:    GENOP(OP -VAL -1)        \Dn
  558. other;                    \Register values are:
  559.                     \REG:  0  1  2  3  4  5  6  7
  560. end;    \SRCOFF                 VAL: -1 -2 -3 -4 -5 -6 -7 -8
  561.  
  562.  
  563.  
  564. proc    PUSHEM;        \Push register p-stack
  565. \This doesn't push all the registers, instead it has a one-register hysteresis
  566. \ which allows any two adjacent values to simultaneously be in registers.
  567. \ This does not affect condition codes. (See comments for BALANCE.)
  568. int    MASK, PTR, D;
  569. begin
  570. GENOP($48E7);                \MOVEM.L D1-Dpstop-2,-(SP)
  571. MASK:= 0;                \Build register list mask
  572. PTR:= $4000;
  573. for D:= 1, PSTOP-2 do
  574.     [MASK:= MASK ! PTR; PTR:= PTR >>1];
  575. GENOP(MASK);
  576.  
  577. GENOP($C141 + (PSTOP-1) <<9);        \EXG Dpsotp-1,D1
  578.  
  579. DSP:= DSP -(PSTOP -2);
  580. LASTOP:= -1;                \Can't optimize
  581. end;    \PUSHEM
  582.  
  583.  
  584.  
  585. proc    PULLEM;        \Pull register p-stack
  586. \(This does not affect condition codes.)
  587. int    MASK, PTR, D;
  588. begin
  589. GENOP($C141 + (PSTOP-1) <<9);        \EXG Dpsotp-1,D1
  590.  
  591. GENOP($4CDF);                \MOVEM.L (SP)+,D1-Dpstop-2
  592. MASK:= 0;                \Build register list mask
  593. PTR:= 2;
  594. for D:= 1, PSTOP-2 do
  595.     [MASK:= MASK!PTR; PTR:= PTR+PTR];
  596. GENOP(MASK);
  597.  
  598. DSP:= DSP +PSTOP -2;
  599. LASTOP:= -1;                \Can't optimize
  600. end;    \PULLEM
  601.  
  602.  
  603.  
  604. proc    NEED1;
  605. \Need one p-stack value, Dsp. Make sure it is available in a register.
  606. \ This does not affect condition codes.
  607. begin
  608. if DSP >= PSTOP then PUSHEM;
  609. if DSP < 1 then PULLEM;
  610. end;    \NEED1
  611.  
  612.  
  613.  
  614. proc    NEEDNOS;
  615. \Need one p-stack value, Dsp-1 (NOS). Make sure it is available in a reg.
  616. begin
  617. DSP:= DSP -1;
  618. \NEED1;
  619. if DSP >= PSTOP then PUSHEM;
  620. if DSP < 1 then PULLEM;
  621. DSP:= DSP +1;
  622. end;    \NEEDNOS
  623.  
  624.  
  625.  
  626. proc    NEED2;
  627. \Need two p-stack values, Dsp and Dsp-1. Make sure they are in registers.
  628. begin
  629. if DSP >= PSTOP then PUSHEM;
  630. if DSP <= 1 then PULLEM;
  631. end;    \NEED2
  632.  
  633. \----------------------------------------------------------------------
  634.  
  635. proc    FPUSHEM;    \Push floating-point register p-stack
  636. \This doesn't push all the registers, instead it has a one-register hysteresis
  637. \ Which allows any two adjacent values to simultaneously be in registers.
  638. \ This does not affect condition codes.
  639. begin
  640. GENOP($F227); GENOP($7500);        \FMOVE.D FP2,-(SP)
  641. GENOP($F227); GENOP($7480);        \FMOVE.D FP1,-(SP)
  642. GENOP($F200); GENOP($0C80);        \FMOVE.X FP3,FP1
  643.  
  644. FPSP:= FPSP -(FPSTOP -2);
  645. LASTOP:= -1;                \Can't optimize
  646. end;    \FPUSHEM
  647.  
  648.  
  649.  
  650. proc    FPULLEM;    \Pull floating-point register p-stack
  651. \ This does not affect condition codes.
  652. begin
  653. GENOP($F200); GENOP($0580);        \FMOVE.X FP1,FP3
  654. GENOP($F21F); GENOP($5480);        \FMOVE.D (SP)+,FP1
  655. GENOP($F21F); GENOP($5500);        \FMOVE.D (SP)+,FP2
  656.  
  657. FPSP:= FPSP +FPSTOP -2;
  658. LASTOP:= -1;                \Can't optimize
  659. end;    \FPULLEM
  660.  
  661.  
  662.  
  663. proc    FNEED1;
  664. \Need one p-stack value, FPsp. Make sure it is available in a register.
  665. \ This does not affect condition codes.
  666. begin
  667. if FPSP >= FPSTOP then FPUSHEM;
  668. if FPSP < 1 then FPULLEM;
  669. end;    \FNEED1
  670.  
  671.  
  672.  
  673. proc    FNEEDNOS;
  674. \Need one p-stack value, FPsp-1 (NOS). Make sure it is available in a reg.
  675. begin
  676. FPSP:= FPSP -1;
  677. FNEED1;
  678. FPSP:= FPSP +1;
  679. end;    \FNEEDNOS
  680.  
  681.  
  682.  
  683. proc    FNEED2;
  684. \Need two p-stack values, FPsp and FPsp-1. Make sure they are in registers.
  685. begin
  686. if FPSP >= FPSTOP then FPUSHEM;
  687. if FPSP <= 1 then FPULLEM;
  688. end;    \FNEED2
  689.  
  690.  
  691.  
  692. proc    BALANCE;    \Balance the stack by setting it to a known state.
  693. \This is required because the pseudo stack has hysteresis. Whenever two
  694. \ Paths of the code converge, the stack must be in the same state for both.
  695. \ This cannot, and does not, affect condition codes because of the 'FOR'
  696. \ and 'CAJ' pseudo ops.
  697. begin
  698. if DSP = PSTOP-1 then PUSHEM else NEED1;
  699. if FPSP = FPSTOP-1 then FPUSHEM else FNEED1;
  700. end;    \BALANCE
  701.  
  702. \----------------------------------------------------------------------
  703.  
  704. proc    GENARG;        \Generate code to pop proc arguments.
  705. \That is, move them from the p-stack, and stack, to the heap.
  706. int    ARG,    \Number of arguments remaining
  707.     NOS,    \Next on stack
  708.     N,    \Number of arguments currently in registers
  709.     MASK,    \Register list for MOVEM instruction
  710.     PTR,    \Bit pointer
  711.     I;
  712.  
  713. begin
  714. ARG:= VAL /INTSIZE;            \The total number of arguments
  715. while ARG > 0 do
  716.     begin
  717.     NEEDNOS;
  718.     NOS:= DSP-1;
  719.     N:= if ARG<NOS then ARG else NOS;    \Take smaller
  720.     if N >= 2 then
  721.         begin            \Use MOVEM.L
  722.         MASK:= 0;        \Build register list mask
  723.         PTR:= 2;        \Initialize bit pointer to D1
  724.         \Move PTR to first register if it't not D1
  725.         for I:= 1, NOS-N do PTR:= PTR +PTR;
  726.  
  727.         \Move PTR to last register, setting mask bits along the way.
  728.         for I:= 1, N do
  729.             [MASK:= MASK !PTR; PTR:= PTR +PTR];
  730.  
  731.         ARG:= ARG -N;        \Decrement argument counter
  732.         if ARG > 0 then
  733.             [GENOP($48ED);    \MOVEM.L Dsp-1...Dsp-rem-1,4*arg(A5)
  734.             GENOP(MASK);
  735.             GENOP(INTSIZE *ARG)]
  736.         else    [GENOP($48D5);    \MOVEM.L Dsp-1...Dsp-rem-1,(A5)
  737.             GENOP(MASK)];
  738.         DSP:= DSP -N;        \Pop registers (fixed up by NEEDNOS)
  739.         end
  740.     else    begin            \Only one argument in a register
  741.         ARG:= ARG -1;
  742.         if ARG > 0 then
  743.             [ONEOP($2B40);    \MOVE.L Dsp-1,4*arg(A5)
  744.             GENOP(INTSIZE *ARG)]
  745.         else    ONEOP($2A80);    \MOVE.L Dsp-1,(A5)
  746.         DSP:= DSP -1;        \Pop register
  747.         end;
  748.     end;
  749. end;    \GENARG
  750.  
  751. \----------------------------------------------------------------------
  752.  
  753. proc    OPTIMIZE; int OP;
  754. \Optimize by combining OP with a previous LOD or IMM.
  755. \ I.e. try to replace the source register with the source of a previous LOD.
  756. begin
  757. case LASTOP of
  758.   $01:    begin                \LOD
  759.     GENPC(if LASTVAL>0 then -4 else -2);
  760.     OP:= OP & $FFC0;        \Remove old source code bits
  761.     case of
  762.         LASTVAL>0:    [GENOP(OP + $28 + LASTLEV);    \off(Alev)
  763.             GENOP(LASTVAL)];
  764.         LASTVAL=0:    GENOP(OP + $10 + LASTLEV);    \(Alev)
  765.         LASTVAL<0:    GENOP(OP -LASTVAL -1)        \Dn
  766.     other;
  767.     end;
  768.   $0B:    begin                \IMM
  769.     GENPC(-6);
  770.     GENOP((OP & $FFC0) + $3C);    \#xxx,Dsp-1
  771.     GENOP(SWAPWD(LASTVAL));
  772.     GENOP(LASTVAL);
  773.     end
  774. other    GENOP(OP);            \Dsp,Dsp-1
  775. end;    \OPTIMIZE
  776.  
  777.  
  778.  
  779. proc    OPTIMX(OP);    \Optimize a 2-register opcode
  780. int    OP;
  781. begin
  782. DSP:= DSP-1;
  783. NEED2;
  784. OPTIMIZE(OP + (DSP-1) <<9 + DSP);
  785. end;    \OPTIMX
  786.  
  787.  
  788.  
  789. proc    STOOFF; int OP;
  790. \Generate a destination effective address code for STO opcode
  791. begin    \ E.g: MOVE.L D1,4(A0)
  792. case of
  793.  VAL>0:    [OPTIMIZE(OP + LEV <<9 + $140);        \off(Alev)
  794.     GENOP(VAL)];
  795.  VAL=0:    OPTIMIZE(OP + LEV <<9 + $80);        \(Alev)
  796.  VAL<0:    OPTIMIZE(OP + (-VAL-1) <<9)        \Dn
  797. other;
  798. end;    \STOOFF
  799.  
  800.  
  801.  
  802. proc    GENCMP(OP);    \Generate compare instruction
  803. int    OP;
  804. begin
  805. DSP:= DSP-1;
  806. NEED2;
  807. if LASTOP=\IMS\$24 & LASTVAL=0 then
  808.     [GENPC(-2);
  809.     ONEOP($4A80)]                \TST.L Dsp-1
  810. else    OPTIMIZE($B080 + (DSP-1) <<9 + DSP);    \CMP.L Dsp,Dsp-1
  811.  
  812. ONEOP(OP);                    \SCC Dsp-1
  813. ONEOP($4880);                    \EXT.W Dsp-1
  814. ONEOP($48C0);                    \EXT.L Dsp-1
  815. end;    \GENCMP
  816.  
  817. \----------------------------------------------------------------------
  818.  
  819. proc    GENFCMP(OP);    \Generate floating compare instruction
  820. int    OP;
  821. begin
  822. FPSP:= FPSP-1;                    \Compare NOS to TOS
  823. FNEED2;                        \Compare dest to source
  824.                         \Written: source, dest
  825. GENOP($F200);                    \FCMP.S FPsp,FPsp-1
  826. GENOP($0038 + FPSP <<10 + (FPSP-1) <<7);
  827.  
  828. \??? INCOMPATABLE WITH 68881 ???
  829. \GENOP($F240 + DSP);                \\FSCC Dsp
  830. \GENOP(OP);
  831. GENOP(OP +DSP);                    \SCC Dsp
  832.  
  833. GENOP($4880 + DSP);                \EXT.W Dsp
  834. GENOP($48C0 + DSP);                \EXT.L Dsp
  835. DSP:= DSP+1;
  836. FPSP:= FPSP-1;
  837. end;    \GENFCMP
  838.  
  839. \----------------------------------------------------------------------
  840.  
  841. proc    BRANCH(OP);    \Generate branch instruction
  842. int    OP;
  843. int    I;
  844. \Note that "fixed" locations are assumed to be generated as 0 or
  845. \ as a jump-to-self initially. The short branch should not be used
  846. \ in this case.
  847. begin
  848. I:= VAL - (PC+2);
  849. if ABS(I)<=$7F & VAL#0 \forward ref\ & I#0 & VAL#PC then
  850.     GENOP(OP + (I&$FF))
  851. else    [GENOP(OP);
  852.     GENOP(VAL-PC)];            \Beware of +/- 32K address limitation
  853. end;    \BRANCH
  854.  
  855.  
  856.  
  857. proc    GENBRA(OP);
  858. int    OP;
  859. \Generate an optimized branch on condition to replace a conditional
  860. \ opcode followed by a JOC opcode. (Saves 4 words.)
  861. begin
  862. GENPC(-6);
  863. BRANCH(OP);
  864. end;    \GENBRA
  865.  
  866.  
  867.  
  868. begin    \GEN
  869. \NOTE: The p-stack grows upward starting with D1. DSP is the top of the
  870. \ p-stack, an empty location. The convention is: PUSH =  MOVE  D0,(DSP)+
  871. \ and PULL =  MOVE  -(DSP),D0
  872.  
  873. case OP of
  874.   $00:\EXIT\    [GENOP($4EF8);                \JMP VEXIT.W
  875.         GENOP(VEXIT)];    \Warning: registers are not restored
  876.   $01:\LOD\    [NEED1;
  877.         SRCOFF($2000 + DSP <<9);        \MOVE.L off(Alev),Dsp
  878.         DSP:= DSP+1];
  879.   $02:\LDX\    [NEEDNOS;    \Indexed load (push) a byte   LDX, LEV, OFF
  880.         if LASTOP=\IMS\$24 then
  881.             [GENPC(-2);
  882.             SRCOFF($2C40);            \MOVEA.L off(Alev),A6
  883.             GENOP($7000 + (DSP-1) <<9);        \MOVEQ #0,Dsp-1
  884.             if LASTVAL # 0 then
  885.             [GENOP($102E + (DSP-1)<<9);    \MOVE.B lv(A6),Dsp-1
  886.             GENOP(LASTVAL);
  887.             OP:= -1]    \(Can't optimize with JOC)
  888.             else GENOP($1016 + (DSP-1)<<9)]    \MOVE.B (A6),Dsp-1
  889.         else
  890.             [OPTIMIZE($2C40 + DSP-1);        \MOVEA.L Dsp-1,A6
  891. \            [ONEOP($2C40);            \\MOVEA.L Dsp-1,A6
  892.             SRCOFF($DDC0);            \ADDA.L off(Alev),A6
  893.             GENOP($7000 + (DSP-1) <<9);        \MOVEQ #0,Dsp-1
  894.             GENOP($1016 + (DSP-1) <<9)];    \MOVE.B (A6),Dsp-1
  895.         end;
  896.   $03:\STO\    [DSP:= DSP-1;
  897.         NEED1;        \Store (pop) into a variable   STO, LEV, OFF
  898.         if LASTOP=\IMS\$24 & VAL<0 then
  899.             [GENPC(-2);            \MOVEQ #lastval,Dval
  900.             GENOP($7000 + (-VAL-1) <<9 + (LASTVAL & $FF))]
  901.         else if LASTOP=\IMS\$24 & LASTVAL=0 then
  902.             [GENPC(-2);
  903.             SRCOFF($4280)]            \CLR.L off(Alev)
  904.         else STOOFF($2000 + DSP)];        \MOVE.L Dsp,off(Alev)
  905.   $04:\STX\    [DSP:= DSP-1;
  906.         NEED2;        \Indexed store (pop) to a byte  STX, LEV, OFF
  907.         SRCOFF($2C40);                \MOVEA.L off(Alev),A6
  908.         GENOP($1D80 + DSP);            \MOVE.B Dsp,0(A6,Dsp-1)
  909.         GENOP($0800 + (DSP-1) <<12);
  910.         DSP:= DSP-1];    \(POP BOTH)
  911.   $05:\CAL\    BRANCH($6100);                \BSR ADDR
  912.   $06:\RET\    if LASTOP # $06 \RET\ then
  913.             [GENOP($2A48 + LEV);        \MOVEA.L Alev,A5
  914. \$$$
  915. \            GENOP($F21F); GENOP($5480);        \\FMOVE.D (SP)+,FP1
  916. \            GENOP($F21F); GENOP($5500);        \\FMOVE.D (SP)+,FP2
  917. \            GENOP($F21F); GENOP($5580);        \\FMOVE.D (SP)+,FP3
  918.             GENOP($4CDF);        \MOVEM.L (SP)+,D1-Dsptop0-1/Alev
  919.             MASK:= $100 <<LEV;        \Set mask for Alev
  920.             PTR:= 2;            \Point to D1
  921.             for I:= 1, PSTOP0-1 do    \Build register list mask
  922.             [MASK:= MASK !PTR; PTR:= PTR +PTR];
  923.             GENOP(MASK);
  924.             GENOP($4E75)];            \RTS
  925.   $07:\JMP\    begin
  926.         BALANCE;
  927.         if CL=64 then    \Module linkage
  928.             [GENOP($4EF9);            \JMP val.L
  929.             CLOSEOBJ;
  930.             CHOUT3(^#);
  931.             GENOP(SWAPWD(VAL));
  932.             GENOP(VAL)]
  933.         else    BRANCH($6000);            \BRA ADDR
  934.         end;
  935.   $08:\JOC\    begin        \Jump on condition (false)  JOC, ADDR
  936.         DSP:= DSP-1;
  937.         BALANCE;    \(If the stack is changed, LASTOP:= -1)
  938.         case LASTOP of
  939.           $12:\EQ\    GENBRA($6600);        \BNE ADDR
  940.           $13:\NE\    GENBRA($6700);        \BEQ ADDR
  941.           $14:\GE\    GENBRA($6D00);        \BLT ADDR
  942.           $15:\GT\    GENBRA($6F00);        \BLE ADDR
  943.           $16:\LE\    GENBRA($6E00);        \BGT ADDR
  944.           $17:\LT\    GENBRA($6C00);        \BGE ADDR
  945.           $01,\LOD\ $0B,\IMM\
  946.           $0D,\ADD\ $0E,\SUB\ $11,\NEG\
  947.           $1A,\OR\  $1B,\AND\ $1C,\NOT\
  948.           $1D,\EOR\ $24,\IMS\ $3E,\LSL\
  949.           $3F:\LSR\    BRANCH($6700);        \BEQ ADDR
  950.           $02:\LDX\    [GENPC(-4);
  951.                 GENOP($4A16);        \TST.B (A6)
  952.                 BRANCH($6700)]        \BEQ ADDR
  953.         other    [NEED1;
  954.             GENOP($4A80 + DSP);        \TST.L Dsp
  955.             BRANCH($6700)];            \BEQ ADDR
  956.         end;
  957.   $09:\HPI\    [GENOP($48E7);            \MOVEM.L D1-Dsptop0-1/Alev,-(SP)
  958.         MASK:= $80 >>LEV;        \Set mask for Alev
  959.         PTR:= $4000;            \Point to D1
  960.         for I:= 1, PSTOP0-1 do        \Build register list mask
  961.             [MASK:= MASK !PTR; PTR:= PTR >>1];
  962.         GENOP(MASK);
  963. \$$$
  964. \        GENOP($F227); GENOP($7580);        \\FMOVE.D FP3,-(SP)
  965. \        GENOP($F227); GENOP($7500);        \\FMOVE.D FP2,-(SP)
  966. \        GENOP($F227); GENOP($7480);        \\FMOVE.D FP1,-(SP)
  967.         GENOP($204D + LEV <<9);            \MOVEA.L A5,Alev
  968.         if VAL > 0 then
  969.             [GENOP($4BED);            \LEA bytes(A5),A5
  970.             GENOP(VAL)];            \(Fast increment A5)
  971.         ];
  972.   $0A:\ARG\    if LASTOP=\IMS\$24 & LASTVAL=0 & VAL=INTSIZE then
  973.             [GENPC(-2);        \(Passing a zero)
  974.             GENOP($4295);            \CLR.L (A5)
  975.             DSP:= DSP-1]
  976.         else if VAL=INTSIZE then    \(Passing only one argument)
  977.             [OPTIMIZE($2A80 + DSP-1);    \MOVE.L Dsp-1,(A5)
  978.             DSP:= DSP-1]
  979.         else    GENARG;
  980.   $0B:\IMM\    begin
  981.         NEED1;        \Immediate load of a value   IMM, #XXX
  982.         if CL=7 then    \Position-independant relocate for strings, etc.
  983.             [GENOP($4DFA);            \LEA d(PC),A6
  984.             GENOP(VAL-PC);
  985.             GENOP($200E + DSP <<9);        \MOVE.L A6,Dsp
  986.             OP:= -1]        \Can't optimize
  987.         else    [GENOP($203C + DSP <<9);    \MOVE.L #xxx,Dsp
  988.             GENOP(SWAPWD(VAL));        \Gen high and low words
  989.             GENOP(VAL)];
  990.         DSP:= DSP+1;
  991.         end;
  992.   $0C:\CML\    [GENOP($4EB8);                \JSR ADDR.W
  993.         GENOP(INTTBL + VAL *6)];
  994.   $0D:\ADD\    [DSP:= DSP-1;
  995.         NEED2;
  996.         if LASTOP=\IMS\$24 & LASTVAL<=8 & LASTVAL>=1 then
  997.            [GENPC(-2);
  998.            GENOP($5080 + (LASTVAL&$7) <<9 + DSP-1)]    \ADDQ.L #val,Dsp-1
  999.         else OPTIMIZE($D080 + (DSP-1) <<9 + DSP)];    \ADD.L Dsp,Dsp-1
  1000.   $0E:\SUB\    \TOS := NOS - TOS    Dsp-1 := Dsp-1 - Dsp
  1001.         [DSP:= DSP-1;
  1002.         NEED2;
  1003.         if LASTOP=\IMS\$24 & LASTVAL<=8 & LASTVAL>=1 then
  1004.            [GENPC(-2);
  1005.            GENOP($5180 + (LASTVAL&$7) <<9 + DSP-1)]    \SUBQ.L #val,Dsp-1
  1006.         else OPTIMIZE($9080 + (DSP-1) <<9 + DSP)];    \SUB.L Dsp,Dsp-1
  1007.   $0F:\MUL\    [DSP:= DSP-1;        \MULS Dsp,Dsp-1
  1008.         NEED2;
  1009.         GENOP($4EB8); GENOP(MUL1 + 6 *(DSP-2))];    \JSR MULx.W
  1010.   $10:\DIV\    [DSP:= DSP-1;
  1011.         NEED2;        \TOS := NOS / TOS   Dsp-1 := Dsp-1 / Dsp
  1012.         GENOP($4EB8); GENOP(DIV1 + 6 *(DSP-2))];    \JSR DIVx.W
  1013.   $11:\NEG\    [NEEDNOS; ONEOP($4480)];        \NEG.L Dsp-1
  1014.   $12:\EQ\    GENCMP($57C0);                \SEQ
  1015.   $13:\NE\    GENCMP($56C0);                \SNE
  1016.   $14:\GE\    GENCMP($5CC0);                \SGE
  1017.   $15:\GT\    GENCMP($5EC0);                \SGT
  1018.   $16:\LE\    GENCMP($5FC0);                \SLE
  1019.   $17:\LT\    GENCMP($5DC0);                \SLT
  1020.   $18:\FOR\    [OPTIMX($B080);                \CMP.L Dsp,Dsp-1
  1021.         BALANCE;    \(Does not affect condition codes)
  1022.         BRANCH($6C00);                \BGE ADDR
  1023.         DSP:= DSP-1];    \(Overall effect of popping)
  1024.   $19:\INC\            \Increment and push   INC, LEV, OFF
  1025.         SRCOFF($5280);                \ADDQ.L #1,off(Alev)
  1026.   $1A:\OR\    OPTIMX($8080);                \OR.L Dsp,Dsp-1
  1027.   $1B:\AND\    OPTIMX($C080);                \AND.L Dsp,Dsp-1
  1028.   $1C:\NOT\    [NEEDNOS; ONEOP($4680)];        \NOT.L Dsp-1
  1029.   $1D:\EOR\    [DSP:= DSP-1;    \(Can't optimize)
  1030.         NEED2;
  1031.         GENOP($B180 + DSP <<9 + DSP-1)];    \EOR.L Dsp,Dsp-1
  1032.   $1E:\DBA\    begin        \TOS:= NOS + TOS*4  (DBA)
  1033.         DSP:= DSP-1;    \ Dsp=TOS=INDEX, Dsp-1 = NOS = base address
  1034.         NEED2;
  1035.         if LASTOP=\IMS\$24 & LASTVAL<32 then
  1036.             begin
  1037.             GENPC(-2);
  1038.             case LASTVAL of
  1039.               0:  ;    \(save 3 wds, 24 cys)
  1040.               1:  ONEOP($5880);            \ADDQ.L #4,Dsp-1
  1041.               2:  ONEOP($5080)            \ADDQ.L #8,Dsp-1
  1042.             other [GENOP($7000 + DSP<<9 + LASTVAL<<2);    \MOVEQ #lastval*4,Dsp
  1043.               GENOP($D080 + (DSP-1) <<9 + DSP)];    \ADD.L Dsp,Dsp-1
  1044.             end
  1045.         else
  1046.             [GENOP($E580 + DSP);        \ASL.L #2,Dsp
  1047.             GENOP($D080 + (DSP-1) <<9 + DSP)];    \ADD.L Dsp,Dsp-1
  1048.         end;
  1049.   $1F:\STD\    [DSP:= DSP-1;
  1050.         NEED2;        \Indirect save (STD)  (NOS) := TOS
  1051.         ONEOP($2C40);                \MOVEA.L Dsp-1,A6
  1052.         GENOP($2C80 + DSP);            \MOVE.L Dsp,(A6)
  1053.         DSP:= DSP-1];    \(Pop both)
  1054.   $20:\DBX\    begin
  1055.         DSP:= DSP-1;
  1056.         NEED2;          \Indirect get (DBX)  TOS := (TOS*4 + NOS)
  1057.         if LASTOP=\IMS\$24 then
  1058.             [GENPC(-2);
  1059.             ONEOP($2C40);            \MOVEA.L Dsp-1,A6
  1060.             if LASTVAL # 0 then
  1061.             [GENOP($202E + (DSP-1)<<9);    \MOVE.L lv*4(A6),Dsp-1
  1062.             GENOP(LASTVAL<<2)]
  1063.             else GENOP($2016 + (DSP-1)<<9)]    \MOVE.L (A6),Dsp-1
  1064.         else
  1065.             [ONEOP($2C40);            \MOVEA.L Dsp-1,A6
  1066.             GENOP($E580 + DSP);            \ASL.L #2,Dsp
  1067.             GENOP($2036 + (DSP-1) <<9);        \MOVE.L 0(A6,Dsp),Dsp-1
  1068.             GENOP($0800 + DSP <<12)];
  1069.         end;
  1070.   $21:\ADR\    [NEED1;        \Load (push) address of variable  ADDR, LEV, OFF
  1071.         SRCOFF($4DC0);                \LEA off(Alev),A6
  1072.         GENOP($200E + DSP <<9);            \MOVE.L A6,Dsp
  1073.         DSP:= DSP+1];
  1074.   $24:\IMS\    [NEED1;        \Short immediate
  1075.         GENOP($7000 + DSP <<9 + (VAL&$FF));    \MOVEQ #val,Dsp
  1076.         DSP:= DSP+1];
  1077.   $25:\CAJ\    [OPTIMX($B080);                \CMP.L Dsp,Dsp-1
  1078.         BALANCE;    \(Does not affect condition codes)
  1079.         BRANCH($6600)];                \BNE ADDR
  1080.   $27:\BAL\    BALANCE;
  1081.   $28:\DRP\    [NEED1;        \(Usually doesn't generate any code)
  1082.         DSP:= DSP-1];
  1083.   $29:\EXT\    [GENOP($4EB9);                \JSR ADDR.L
  1084.         GENOP(SWAPWD(VAL));
  1085.         GENOP(VAL)];
  1086.   $2A:\FLOD\    begin
  1087.         FNEED1;
  1088.         if VAL<0 then
  1089.             [GENOP($F200);            \FMOVE.X FP0,FPsp
  1090.             GENOP(FPSP <<7)]
  1091.         else    [GENOP($F228 + LEV);        \FMOVE.D off(Alev),FPsp
  1092.             GENOP($5400 + FPSP <<7);
  1093.             GENOP(VAL)];
  1094.         FPSP:= FPSP+1;
  1095.         end;
  1096.   $2B:\FSTO\    begin
  1097.         FPSP:= FPSP-1;
  1098.         FNEED1;
  1099.         if VAL<0 then
  1100.             [GENOP($F200);            \FMOVE.X FPsp,FP0
  1101.             GENOP(FPSP <<10)]
  1102.         else    [\NEED1;
  1103.             GENOP($F228 + LEV);        \FMOVE.D FPsp,off(Alev)
  1104.             GENOP($7400 + FPSP <<7);
  1105.             GENOP(VAL)];
  1106.             end;
  1107.   $2C:\FIMM\    begin
  1108.         FNEED1;        \Immediate load of a value   FIMM, #XXX
  1109.         if CL=7 then    \Position-independant relocate for strings, etc.
  1110.             [GENOP($4DFA);            \LEA d(PC),A6
  1111.             GENOP(VAL-PC);
  1112.             GENOP($200E);            \MOVE.L A6,D0
  1113.             GENOP($F200);            \FMOVE.L D0,FP0
  1114.             GENOP($4000);
  1115.             GENOP($F200);            \FMOVE.X FP0,FPsp
  1116.             GENOP(FPSP <<7)]
  1117.         else    [GENOP($F23C);            \FMOVE.D #xxx,FPsp
  1118.             GENOP($5400 + FPSP <<7);
  1119.             A:= addr RLATOM;  \To access individual bytes in RLATOM
  1120.             CLOSEOBJ;
  1121.             for I:= 0,RLSIZE-1 do HEX2OUT(A(I));
  1122.             PC:= PC +RLSIZE];
  1123.         FPSP:= FPSP+1;
  1124.         end;
  1125.   $2D:\FADD\    [FPSP:= FPSP-1;                \FADD.X FPsp,FPsp-1
  1126.         FNEED2;
  1127.         GENOP($F200);
  1128.         GENOP($0022 + FPSP <<10 + (FPSP-1) <<7)];
  1129.   $2E:\FSUB\    [FPSP:= FPSP-1;                \FSUB.X FPsp,FPsp-1
  1130.         FNEED2;
  1131.         GENOP($F200);    \TOS := NOS - TOS    FPsp-1 := FPsp-1 - FPsp
  1132.         GENOP($0028 + FPSP <<10 + (FPSP-1) <<7)];
  1133.   $2F:\FMUL\    [FPSP:= FPSP-1;                \FMUL.X FPsp,FPsp-1
  1134.         FNEED2;
  1135.         GENOP($F200);    \TOS := NOS / TOS   FPsp-1 := FPsp-1 * FPsp
  1136.         GENOP($0023 + FPSP <<10 + (FPSP-1) <<7)];
  1137.   $30:\FDIV\    [FPSP:= FPSP-1;                \FDIV.X FPsp,FPsp-1
  1138.         FNEED2;
  1139.         GENOP($F200);    \TOS := NOS / TOS   FPsp-1 := FPsp-1 / FPsp
  1140.         GENOP($0020 + FPSP <<10 + (FPSP-1) <<7)];
  1141.   $31:\FNEG\    [FNEEDNOS;
  1142.         GENOP($F200);                \FNEG.X FPsp-1
  1143.         GENOP($001A + (FPSP-1) <<10 + (FPSP-1) <<7)];
  1144.                 \Compare NOS to TOS (NOS - TOS)
  1145.   $32:\FEQ\    GENFCMP(\$0001\$57C0);    \??? INCOMPATABLE WITH 68881 ???
  1146.   $33:\FNE\    GENFCMP(\$000E\$56C0);
  1147.   $34:\FGE\    GENFCMP(\$0013\$5CC0);
  1148.   $35:\FGT\    GENFCMP(\$0012\$5EC0);
  1149.   $36:\FLE\    GENFCMP(\$001D\$5FC0);            \(not GT)
  1150.   $37:\FLT\    GENFCMP(\$0014\$5DC0);
  1151.   $38:\TRA\    [FPSP:= FPSP-1;        \TOS:= TOS *8 + NOS
  1152.         FNEED1;              \Dsp-1 Dsp-1   FPsp-1
  1153.         NEEDNOS;
  1154.         GENOP($E780 + DSP-1);            \ASL.L #3,Dsp-1
  1155.         GENOP($F200);                \FMOVE.X FPsp,FP0
  1156.         GENOP(FPSP <<10);
  1157.         GENOP($F200); GENOP($6000);        \FMOVE.L FP0,D0
  1158.         GENOP($D080 + (DSP-1) <<9)];        \ADD.L D0,Dsp-1
  1159.   $39,\TRX\
  1160.   $3A:\TRI\    [DSP:= DSP-1;        \TOS:= (TOS *8 + NOS)
  1161.         NEED1;              \FPsp-1 Dsp-1   FPsp-1
  1162.         FNEEDNOS;
  1163.         GENOP($E780 + DSP);            \ASL.L #3,Dsp
  1164.         GENOP($F200);                \FMOVE.X FPsp-1,FP0
  1165.         GENOP((FPSP-1) <<10);
  1166.         GENOP($F200); GENOP($6000);        \FMOVE.L FP0,D0
  1167.         GENOP($D080 + DSP);            \ADD.L Dsp,D0
  1168.         GENOP($2C40);                \MOVEA.L D0,A6
  1169.         GENOP($F216);                \FMOVE.D (A6),FPsp-1
  1170.         GENOP($5400 + (FPSP-1) <<7)];
  1171.   $3B:\STT\    [DSP:= DSP-1;        \Store TOS at NOS, pop both
  1172.         NEED1;              \     FPsp-1  Dsp-1
  1173.         FPSP:= FPSP-1;
  1174.         FNEED1;
  1175.         GENOP($2C40 + DSP);            \MOVEA.L Dsp,A6
  1176.         GENOP($F216);                \FMOVE.D FPsp,(A6)
  1177.         GENOP($7400 + FPSP <<7)];
  1178.   $3E:\LSL\    [DSP:= DSP-1;        \TOS:= NOS << TOS
  1179.         NEED2;            \Dsp-1:= Dsp-1 << Dsp
  1180.         if LASTOP=\IMS\$24 & LASTVAL<=8 & LASTVAL>=1 then
  1181.            [GENPC(-2);
  1182.            GENOP($E188 + (LASTVAL&$7) <<9 + DSP-1)]  \LSL.L #val,Dsp-1
  1183.         else GENOP($E1A8 + DSP <<9 + DSP-1)];         \LSL.L Dsp,Dsp-1
  1184.   $3F:\LSR\    [DSP:= DSP-1;        \TOS:= NOS >> TOS
  1185.         NEED2;            \Dsp-1:= Dsp-1 >> Dsp
  1186.         if LASTOP=\IMS\$24 & LASTVAL<=8 & LASTVAL>=1 then
  1187.            [GENPC(-2);
  1188.            GENOP($E088 + (LASTVAL&$7) <<9 + DSP-1)]  \LSR.L #val,Dsp-1
  1189.         else GENOP($E0A8 + DSP <<9 + DSP-1)]         \LSR.L Dsp,Dsp-1
  1190. other    ERROR(0);
  1191.  
  1192. if CL&32 then    \Output dummy bytes for constant real array pointers
  1193.     begin
  1194.     CLOSEOBJ;
  1195.     for I:= INTSIZE, RLSIZE-1 do [HEX2OUT(0); PC:= PC+1];
  1196.     end;
  1197. LASTOP:= OP;
  1198. LASTLEV:= LEV;
  1199. LASTVAL:= VAL;
  1200. end;    \GEN
  1201.  
  1202. \======================================================================
  1203.  
  1204. proc    FIXUP(I);    \Fix forward references
  1205. int    I;
  1206. begin
  1207. GEN(\BAL\$27, 0, 0, 0);            \First, balance the stack
  1208. CLOSEOBJ;
  1209. CHOUT3(^^); HEX4OUT(I+2);        \Skip opcode
  1210. LASTOP:= -1;                \Don't optimize
  1211. end;    \FIXUP
  1212.  
  1213.  
  1214.  
  1215. proc    LOOKUP;        \Lookup identifier in symbol table
  1216. \Inputs: IDENT, HASH
  1217. \Outputs: IDTYPE, VAL, LEV, SYMNUM.
  1218. \If two identifiers of the same name are in the symbol table
  1219. \ then the most recent entry is used.
  1220. int    I, K, PNTR;
  1221. begin
  1222. PNTR:= BOXES(HASH);
  1223. loop    begin
  1224.     if PNTR = \empty\ -1 then [IDTYPE:= UNDEF; quit];
  1225.     I:= 0; K:= PNTR;
  1226.     while IDENT(I)=SYMBOL(K) & I<SIGCHAR do
  1227.         [I:= I +1; K:= K +SYMAX];
  1228.     if I=SIGCHAR then    \FOUND
  1229.         [IDTYPE:= SYMTYP(PNTR);
  1230.         VAL:= SYMVAL(PNTR);
  1231.         LEV:= SYMLEV(PNTR);
  1232.         SYMNUM:= PNTR;        \(FOR FORWARD PROC)
  1233.         quit];
  1234.     PNTR:= SYMPNT(PNTR);
  1235.     end;
  1236. end;    \LOOKUP
  1237.  
  1238.  
  1239.  
  1240. proc    INSERT(STYP, SLEV, SVAL);
  1241. \Insert the current identifier into the symbol table
  1242. \Inputs:  STYP, SLEV, SVAL, IDENT, HASH, NOSYM, SYMBOL, & BOXES.
  1243. int    STYP, SLEV, SVAL;
  1244. int    I, K;
  1245. begin
  1246. LOOKUP;
  1247. if IDTYPE#UNDEF then if LEV = LEVEL then \collision\ ERROR(11);
  1248. if NOSYM >= SYMAX then \table full\ [ERROR(3); NOSYM:= SYMAX -1];
  1249. K:= NOSYM;
  1250. for I:= 0, SIGCHAR-1 do [SYMBOL(K):= IDENT(I); K:= K +SYMAX];
  1251. SYMTYP(NOSYM):= STYP;
  1252. SYMLEV(NOSYM):= SLEV;
  1253. SYMVAL(NOSYM):= SVAL;
  1254. SYMPNT(NOSYM):= BOXES(HASH);        \Link back
  1255. BOXES(HASH):= NOSYM;
  1256. NOSYM:= NOSYM +1;
  1257. end;    \INSERT
  1258.  
  1259.  
  1260.  
  1261. proc    GETCON;        \Get a constant -- either by value or by name
  1262. int    NEG;
  1263. begin
  1264. if ATOM = ^+ then RATOM;
  1265. if ATOM = ^- then [NEG:= true; RATOM] else NEG:= false;
  1266. case ATYPE of
  1267.   INTCON:  [if NEG then IATOM:= -IATOM; FACTYP:= INTEGER];
  1268.   REALCON: [if NEG then RLATOM:= -RLATOM; FACTYP:= REAL];
  1269.   IDENTIFIER:
  1270.     begin
  1271.     LOOKUP;
  1272.     case IDTYPE of
  1273.      INCON:    [IATOM:= if NEG then -VAL else VAL;
  1274.         FACTYP:= INTEGER];
  1275.      RLCON:    [RLATOM:= if NEG then -RLTBL(VAL) else RLTBL(VAL);
  1276.         FACTYP:= REAL]
  1277.     other    ERROR(42);
  1278.     end
  1279. other    ERROR(42);
  1280. end;    \GETCON
  1281.  
  1282.  
  1283.  
  1284. fproc    BOOLEXP;
  1285.  
  1286.  
  1287.  
  1288. proc    PROCAL;
  1289. int    SVAL, SLEV, ARGCNT, SID, \K\;
  1290. begin
  1291. SVAL:= VAL; SLEV:= LEV; SID:= IDTYPE;
  1292. RATOM;
  1293. ARGCNT:= 0;
  1294. if ATOM = ^( then
  1295.     begin
  1296. \    K:= 0;        \\Offset to first integer argument
  1297.     repeat    begin
  1298.         RATOM; 
  1299.         BOOLEXP;
  1300.         if FACTYP = INTEGER then
  1301.             [ARGCNT:= ARGCNT + INTSIZE;
  1302.     \*** The following does not work if p-stack overflows ***
  1303. \            GENOP($2B40 + DSP-1);    \\MOVE.L Dsp-1,K(A5)
  1304. \            GENOP(K);
  1305. \            DSP:= DSP-1;
  1306. \            K:= K +INTSIZE\]
  1307.         else    [ARGCNT:= ARGCNT + RLSIZE;
  1308. \            GENOP($F22D);        \\FMOVE.D FPsp-1,K(A5)
  1309. \            GENOP($7400 + (FPSP-1) <<7);
  1310. \            GENOP(K);
  1311. \            FPSP:= FPSP-1;
  1312. \            K:= K +RLSIZE\];
  1313.         end;
  1314.     until ATOM#^,;
  1315.     if ATOM#^) then ERROR(44) else RATOM;
  1316.     end;
  1317. if ARGCNT>0 then GEN(\ARG\10, 0, ARGCNT, 2);
  1318. case of
  1319.   SID>=INPROC & SID<=RLFPROC:        \NORMAL PROCEDURE CALL
  1320.     GEN(\CAL\5, SLEV+1, SVAL, 15);
  1321.   SID=ININT ! SID=RLINT:        \INTRINSIC PROCEDURE CALL
  1322.     GEN(\CML\12, 0, SVAL, 2)
  1323. other    GEN(\ECL\41, 0, SVAL, 3);      \EXTERNAL PROCEDURE CALL
  1324. end;    \PROCAL
  1325.  
  1326.  
  1327.  
  1328. proc    BOOLEXP;    \Boolean expression
  1329. \Outputs factor type (FACTYP)
  1330. int    P1, P2, SFACTYP;
  1331.  
  1332.  
  1333.  
  1334. proc    FACTOR;
  1335.  
  1336.  
  1337.  
  1338. func    STRCON;        \String constant function
  1339. int    SPC;
  1340. begin
  1341. CLOSEOBJ;
  1342. SPC:= PC;
  1343. while CHAR # ^" do
  1344.     begin                \(GETCH -- optimized for speed)
  1345.     case CHAR of
  1346.       ^^:    [CHAR:= CHIN3; LIST(CHAR)];
  1347.       EOF:    [ERROR(63); exit]
  1348.     other    ;
  1349.     HEX2OUT(CHAR); PC:= PC+1;
  1350.     CHAR:= CHIN3;
  1351.     LIST(CHAR);
  1352.     end;
  1353. HEX2OUT(0); PC:= PC+1;
  1354. if PC & 1 then                \Stay on even-byte boundary
  1355.     [HEX2OUT(0); PC:= PC+1];
  1356. GETCH;                    \Skip the close quote
  1357. FACTYP:= INTEGER;
  1358. LASTOP:= -1;                \Can't optimize
  1359. return SPC;                \Return starting address of string
  1360. end;    \STRCON
  1361.  
  1362.  
  1363.  
  1364. func    ARRAYCON;    \Constant arrays
  1365. int    THISEL, NEXTEL, PNTR, SPC, I, INDIRECT, SFACTYP, FIRST;
  1366. def    NULL= -1;
  1367. addr    ENTRY, R;
  1368. begin
  1369. PNTR:= RESERVE(3 *INTSIZE);
  1370. THISEL:= PNTR;
  1371. THISEL(0):= NULL;
  1372.  
  1373. FIRST:= true;                \(Used for mixed-mode detection)
  1374. repeat    RATOM;
  1375.     INDIRECT:= true;
  1376.     case ATOM of
  1377.       ^[:    ENTRY:= ARRAYCON;
  1378.       ^":    ENTRY:= STRCON
  1379.     other    begin
  1380.         INDIRECT:= false;
  1381.         GETCON;
  1382.         if FACTYP = INTEGER then ENTRY:= IATOM
  1383.         else    [ENTRY:= RESERVE(RLSIZE);  \FACTYP = REAL
  1384.             R:= addr RLATOM;
  1385.             for I:= 0, RLSIZE-1 do ENTRY(I):= R(I)];
  1386.         end;
  1387.     NEXTEL:= RESERVE(3 *INTSIZE);
  1388.     THISEL(1):= ENTRY;
  1389.     THISEL(2):= INDIRECT;
  1390.     THISEL(0):= NEXTEL;
  1391.     NEXTEL(0):= NULL;
  1392.     THISEL:= NEXTEL;
  1393.     RATOM;
  1394.  
  1395.     if FACTYP#SFACTYP & ~FIRST then \mixed mode\ ERROR(46);
  1396.     SFACTYP:= FACTYP;
  1397.     FIRST:= false;
  1398. until ATOM#^,;
  1399.  
  1400. if ATOM # ^] then ERROR(50);
  1401. SPC:= PC;
  1402. while PNTR(0) # NULL do            \Follow list linkages & output data
  1403.     begin
  1404.     ENTRY:= PNTR(1);
  1405.     if FACTYP=INTEGER then
  1406.         begin
  1407.         if PNTR(2) \indirect\ then [CLOSEOBJ; CHOUT3(^*)];
  1408.         GENOP(SWAPWD(ENTRY));
  1409.         GENOP(ENTRY);
  1410.         end
  1411.     else    begin            \(FACTYP = REAL)
  1412.         CLOSEOBJ;
  1413.         if PNTR(2) \INDIRECT\ then
  1414.             [CHOUT3(^*);
  1415.             HEX4OUT(SWAPWD(ENTRY));
  1416.             HEX4OUT(ENTRY);
  1417.             for I:= 1,RLSIZE-INTSIZE do HEX2OUT(0)]
  1418.                     \Fill out balance of entry
  1419.         else for I:= 0, RLSIZE-1 do HEX2OUT(ENTRY(I));
  1420.         PC:= PC +RLSIZE;
  1421.         end;
  1422.     PNTR:= PNTR(0);
  1423.     end;
  1424. LASTOP:= -1;                \Don't optimize
  1425. return SPC;                \Return starting address of array
  1426. end;    \ARRAYCON
  1427.  
  1428.  
  1429.  
  1430. proc    SPECFAC;    \Special character factor
  1431. int    SVAL, SPC, R;
  1432. begin
  1433. case ATOM of
  1434.   ^(:    [RATOM;                \Parenthesized expression
  1435.     BOOLEXP;            \(Factor type is unchanged)
  1436.     if ATOM#^) then ERROR(44)];
  1437.   ^":    [GEN(\JMP\7, 0, 0, 7);        \String constant
  1438.     SPC:= PC -4;
  1439.     SVAL:= STRCON;
  1440.     FIXUP(SPC);
  1441.     GEN(\IMM\11, 0, SVAL, 7)];
  1442.   ^[:    [GEN(\JMP\7, 0, 0, 7);
  1443.     SPC:= PC -4;
  1444.     SVAL:= ARRAYCON;
  1445.     FIXUP(SPC);
  1446.     GEN(if FACTYP = INTEGER then \IMM\11 else \FIMM\$2C, 0, SVAL, 7)];
  1447.  ADRSYM: begin                \Get absolute heap address
  1448.     RATOM;
  1449.     if ATYPE # IDENTIFIER then ERROR(45);
  1450.     LOOKUP;
  1451.     case IDTYPE of
  1452.       INVAR, ADDRVAR, RLVAR:
  1453.         if VAL < 0 then ERROR(43) else GEN(\ADR\33, LEV, VAL, 10);
  1454.                 \(Can't take address of a register variable)
  1455.       UNDEF: ERROR(10)        \(Undeclared name)
  1456.     other ERROR(43);        \(Variable expected)
  1457.     FACTYP:= INTEGER;
  1458.     end
  1459. other \illegal factor\ ERROR(26);
  1460. RATOM;
  1461. end;    \SPECFAC
  1462.  
  1463.  
  1464.  
  1465. proc    IDFAC;        \Identifier factor
  1466. int    SLEV, SVAL, SID;
  1467. begin
  1468. LOOKUP;
  1469. SID:= IDTYPE;
  1470. case IDTYPE of
  1471.  UNDEF:    ERROR(10);
  1472.  INVAR, RLVAR:                \Variable
  1473.     begin
  1474.     GEN(if SID = INVAR then \LOD\1 else \FLOD\$2A, LEV, VAL, 10);
  1475.     RATOM;
  1476.     if ATOM=^( then            \It is indexed
  1477.         begin
  1478.         repeat    [RATOM;
  1479.             BOOLEXP;
  1480.             if FACTYP # INTEGER then ERROR(47);
  1481.             GEN(if SID = INVAR then \DBX\32
  1482.                 else \TRI\$3A, 0, 0, 0)]
  1483.         until ATOM # ^, ;
  1484.         if ATOM # ^) then ERROR(44) else RATOM;
  1485.         end;
  1486.     end;
  1487.  ADDRVAR: begin                \Address variable
  1488.     RATOM;
  1489.     if ATOM # ^( then GEN(\LOD\1, LEV, VAL, 10)
  1490.     else    begin            \Array element reference
  1491.         SLEV:= LEV; SVAL:= VAL;
  1492.         RATOM;
  1493.         BOOLEXP;         \Index
  1494.         if FACTYP # INTEGER then ERROR(47);
  1495.         if ATOM # ^) then ERROR(44) else RATOM;
  1496.         GEN(\LDX\2, SLEV, SVAL, 10);
  1497.         end;
  1498.     end;
  1499.  INCON:    begin                \Integer constant identifier
  1500.     if ABS(VAL)<=$7F & VAL#$80000000 then GEN(\IMS\36, 0, VAL, 2)
  1501.         else GEN(\IMM\11, 0, VAL, 3);
  1502.     RATOM;
  1503.     end;
  1504.  RLCON:    begin                \Real constant identifier
  1505.     RLATOM:= RLTBL(VAL); GEN(\FIMM\$2C, 0, 0, 0);
  1506.     RATOM;
  1507.     end
  1508. other    begin                \Procedures used as functions (default)
  1509.     PROCAL;
  1510.     GEN(if SID&1 then \LOD\1 else \FLOD\$2A, 0, -1, 10);
  1511.     \RETURN FUNCTION VALUES IN D0 (= -1)
  1512.     end;
  1513. FACTYP:= if SID & 1 then INTEGER else REAL;    \Odd IDs are integer
  1514. end;    \IDFAC
  1515.  
  1516.  
  1517. begin    \FACTOR
  1518. while ATOM = ^+ do RATOM;        \Ignore unary "+"
  1519. if ATOM = ^- then            \Unary "-"
  1520.     [RATOM;
  1521.     FACTOR;
  1522.     GEN(if FACTYP = INTEGER then \NEG\17
  1523.         else \FNEG\$31, 0, 0, 0)]
  1524. else    case ATYPE of
  1525.      SPECIAL: SPECFAC;
  1526.      INTCON: [FACTYP:= INTEGER;    \Integer constant
  1527.         if ABS(IATOM)<=$7F & IATOM#$80000000 then
  1528.             GEN(\IMS\36, 0, IATOM, 2)
  1529.         else GEN(\IMM\11, 0, IATOM, 3);
  1530.         RATOM];
  1531.      REALCON: [FACTYP:= REAL;    \Real constant
  1532.         GEN(\FIMM\$2C, 0, 0, 0);
  1533.         RATOM]
  1534.     other    IDFAC;            \ATYPE = identifier (default)
  1535. end;    \FACTOR
  1536.  
  1537.  
  1538. proc    SHIFTEXP;
  1539.  
  1540.     proc SHIFTX; int INOP;
  1541.     [if FACTYP # INTEGER then \integer exptected\ ERROR(47);
  1542.     RATOM; FACTOR;
  1543.     if FACTYP # INTEGER then ERROR(47);
  1544.     GEN(INOP, 0, 0, 0)];
  1545.  
  1546. begin    \SHIFTEXP
  1547. FACTOR;
  1548. case ATOM of
  1549.   LSLSYM: SHIFTX(\LSL\$3E);        \ <<
  1550.   LSRSYM: SHIFTX(\LSR\$3F)        \ >>
  1551. other;
  1552. end;    \SHIFTEXP
  1553.  
  1554.  
  1555.  
  1556. proc    TERM;
  1557. int    SFACTYP;
  1558.  
  1559.     proc TERMX; int INOP, RLOP;
  1560.     [RATOM; SHIFTEXP;
  1561.     if SFACTYP # FACTYP then \mixed mode\ ERROR(46);
  1562.     GEN(if FACTYP = INTEGER then INOP else RLOP, 0, 0, 0)];
  1563.  
  1564. begin    \TERM
  1565. SHIFTEXP;
  1566. SFACTYP:= FACTYP;
  1567. loop    case ATOM of
  1568.       ^*:    TERMX(\MUL\15, \FMUL\$2F);
  1569.       ^/:    TERMX(\DIV\16, \FDIV\$30)
  1570.     other    quit;
  1571. end;    \TERM
  1572.  
  1573.  
  1574.  
  1575. proc    ALGEXP;        \Algebriac expression
  1576. int    SFACTYP;
  1577.  
  1578.     proc ALGX; int INOP, RLOP;
  1579.     [RATOM; TERM;
  1580.     if SFACTYP # FACTYP then \mixed mode\ ERROR(46);
  1581.     GEN(if FACTYP = INTEGER then INOP else RLOP, 0, 0, 0)];
  1582.  
  1583. begin    \ALGEXP
  1584. TERM;
  1585. SFACTYP:= FACTYP;
  1586. loop    case ATOM of
  1587.       ^+:    ALGX(\ADD\13, \FADD\$2D);
  1588.       ^-:    ALGX(\SUB\14, \FSUB\$2E)
  1589.     other    quit;
  1590. end;    \ALGEXP
  1591.  
  1592.  
  1593.  
  1594. proc    LOGEXP;        \Logical expression
  1595. int    SFACTYP;
  1596.  
  1597.     proc    LOGX; int INOP, RLOP;
  1598.     [RATOM; ALGEXP;
  1599.     if SFACTYP # FACTYP then \mixed mode\ ERROR(46);
  1600.     GEN(if FACTYP = INTEGER then INOP else RLOP, 0, 0, 0);
  1601.     FACTYP:= INTEGER];
  1602.  
  1603. begin    \LOGEXP
  1604. if ATOM=NOTSYM ! ATOM=^~ then        \Unary 'NOT' operator
  1605.     [RATOM; LOGEXP;
  1606.     if FACTYP # INTEGER then ERROR(47);
  1607.     GEN(\NOT\28, 0, 0, 0)]
  1608. else    [ALGEXP;
  1609.     SFACTYP:= FACTYP;
  1610.     case ATOM of
  1611.       ^=:    LOGX(\EQ\18, \FEQ\$32);
  1612.       ^#:    LOGX(\NE\19, \FNE\$33);
  1613.       ^>:    LOGX(\GT\21, \FGT\$35);
  1614.       ^<:    LOGX(\LT\23, \FLT\$37);
  1615.      GESYM:    LOGX(\GE\20, \FGE\$34);
  1616.      LESYM:    LOGX(\LE\22, \FLE\$36)
  1617.     other];
  1618. end;    \LOGEXP
  1619.  
  1620.  
  1621.  
  1622. proc    BOOLTERM;    \Boolean "&" expressions
  1623. begin
  1624. LOGEXP;
  1625. loop    [if ATOM=^& then
  1626.         [if FACTYP # INTEGER then ERROR(47);
  1627.         RATOM; LOGEXP; GEN(\AND\27, 0, 0, 0);
  1628.         if FACTYP # INTEGER then ERROR(47)]
  1629.     else quit];
  1630. end;    \BOOLTERM
  1631.  
  1632.  
  1633.  
  1634. proc BEXPX; int INOP;
  1635. begin
  1636. if FACTYP # INTEGER then \integer exptected\ ERROR(47);
  1637. RATOM; BOOLTERM;
  1638. if FACTYP # INTEGER then ERROR(47);
  1639. GEN(INOP, 0, 0, 0);
  1640. end;    \BEXPX
  1641.  
  1642.  
  1643.  
  1644. begin    \BOOLEXP
  1645. if ATOM=IFSYM then            \'IF' expression
  1646.     [RATOM; BOOLEXP;
  1647.     GEN(\JOC\8, 0, 0, 7); P1:= PC -4;
  1648.     if ATOM # THENYM then ERROR(22);
  1649.     RATOM; BOOLEXP; SFACTYP:= FACTYP;
  1650.     GEN(\JMP\7, 0, 0, 7); P2:= PC -4;
  1651.     if FACTYP = INTEGER then DSP:= DSP-1 else FPSP:= FPSP-1;
  1652.     FIXUP(P1);
  1653.     if ATOM # ELSEYM then ERROR(30);
  1654.     RATOM; BOOLEXP;
  1655.     if SFACTYP # FACTYP then \mixed mode\ ERROR(46);
  1656.     FIXUP(P2)]
  1657. else    begin                \Boolean "!" (or) expressions
  1658.     BOOLTERM;
  1659.     loop    case ATOM of
  1660.           ^!:    BEXPX(\OR\$1A);
  1661.           ^|:    BEXPX(\EOR\$1D)
  1662.         other quit;
  1663.     end;
  1664. end;    \BOOLEXP
  1665.  
  1666. \----------------------------------------------------------------------
  1667.  
  1668. proc    SSTATEMENT(SSTK);    \(For 'QUIT's in 'CASE' statments)
  1669. int    SSTK;
  1670.  
  1671.  
  1672.  
  1673. proc    STATEMENT;
  1674. int    P2, P3, SFIXS, SLEV, SVAL, SFACTYP, I, SDSP;
  1675.  
  1676.  
  1677.  
  1678. proc    ASSIGN;        \Assignment statement
  1679. \ (Also includes procedure calls)
  1680.  
  1681.     proc    ASSX;
  1682.     [if ATOM # GETSYM then ERROR(21);
  1683.     RATOM;
  1684.     BOOLEXP];            \Right-hand side of assignment
  1685.  
  1686. begin    \ASSIGN
  1687. if ATYPE # IDENTIFIER then
  1688.     \Bad start of a statement\ [ERROR(20); SKIPIT; return];
  1689. LOOKUP; if IDTYPE = UNDEF then [ERROR(10); SKIPIT; return];
  1690. SLEV:= LEV; SVAL:= VAL;            \(BOOLEXP may change LEV & VAL)
  1691. if IDTYPE>=INPROC & IDTYPE<=RLEXT then PROCAL
  1692. else if IDTYPE=INVAR ! IDTYPE=RLVAR then
  1693.     begin
  1694.     SFACTYP:= if IDTYPE = INVAR then INTEGER else REAL;
  1695.     RATOM;
  1696.     if ATOM=^( then            \Indexed
  1697.         begin
  1698.         GEN(if SFACTYP = INTEGER then \LOD\1        \+++
  1699.             else \FLOD\$2A, SLEV, SVAL, 10);
  1700.         RATOM;
  1701.         BOOLEXP;        \First index
  1702.         if FACTYP # INTEGER then ERROR(47);
  1703.         while ATOM = ^, do    \Multiple indexing
  1704.             [GEN(if SFACTYP = INTEGER then \DBX\32
  1705.                 else \TRX\$39, 0, 0, 0);
  1706.             RATOM;
  1707.             BOOLEXP;
  1708.             if FACTYP # INTEGER then ERROR(47)];
  1709.         GEN(if SFACTYP = INTEGER then \DBA\30
  1710.             else \TRA\$38, 0, 0, 0);
  1711.         if ATOM#^) then ERROR(44) else RATOM;
  1712.         ASSX;            \TOS now points to array element
  1713.         GEN(if SFACTYP = INTEGER then \STD\31
  1714.             else \STT\$3B, 0, 0, 0);
  1715.         end
  1716.     else    [ASSX;
  1717.         GEN(if SFACTYP = INTEGER then \STO\3
  1718.             else \FSTO\$2B, SLEV, SVAL, 10)];
  1719.     if FACTYP # SFACTYP then \mixed mode\ ERROR(46);
  1720.     end
  1721. else if IDTYPE = ADDRVAR then        \Address variable
  1722.     begin
  1723.     RATOM;
  1724.     if ATOM = ^( then        \Indexed
  1725.         [RATOM;
  1726.         BOOLEXP;
  1727.         if FACTYP # INTEGER then ERROR(47);
  1728.         if ATOM # ^) then ERROR(44) else RATOM;
  1729.         ASSX;
  1730.         GEN(\STX\4, SLEV, SVAL, 10)]
  1731.     else    [ASSX;
  1732.         GEN(\STO\3, SLEV, SVAL, 10)];
  1733.     if FACTYP # INTEGER then \mixed mode\ ERROR(46);
  1734.     end
  1735. else \statement starting with a constant\ [ERROR(27); SKIPIT];
  1736. end;    \ASSIGN
  1737.  
  1738.  
  1739.  
  1740. proc    CASER; int TYPE;
  1741. int    SPC1, SPC2, SPC3;
  1742.  
  1743.  
  1744.  
  1745. proc    CASER2;        \Compile expression(s) and statement
  1746. begin
  1747. RATOM;                    \Expression
  1748. BOOLEXP;
  1749. if FACTYP # INTEGER then ERROR(47);
  1750. GEN(TYPE, 0, 0, 7);            \Conditional jump of some type
  1751. SPC1:= PC -4;                \SPC1 will be fixed to point to next line
  1752. if ATOM=^, then                \Multiple expressions
  1753.     [SPC3:= SPC1;
  1754.     repeat    RATOM;
  1755.         GENPC(-4);    \Reverse the status of the conditional jump
  1756.         GENOP(OBJBUF(OBJFILL) | $0100);    \(Beware of optimized JOC's)
  1757.         GENOP(SPC3-PC);        \Branch offset (branches must be long)
  1758.         BOOLEXP;
  1759.         if FACTYP # INTEGER then ERROR(47);
  1760.         GEN(TYPE, 0, 0, 7);
  1761.         SPC1:= PC -4;        \Save address of last conditional jump
  1762.     until ATOM # ^,;
  1763.     FIXUP(SPC3)];            \So as to jump to statement
  1764. if ATOM # ^: then [ERROR(49); SKIPIT; return];
  1765. RATOM;
  1766. STATEMENT;
  1767. end;    \CASER2
  1768.  
  1769.  
  1770.  
  1771. begin    \CASER
  1772. CASER2;
  1773. GEN(\JMP\7, 0, 0, 7);            \Jump out of case statement
  1774. SPC2:= PC -4;
  1775. FIXUP(SPC1);                \Fix conditional jump to go to expression
  1776. while ATOM = ^; do            \ on the next line
  1777.     [CASER2;
  1778.     if LASTOP#\JMP\7 then GEN(\JMP\7, 0, SPC2, 7);    \2-jump exit
  1779.     FIXUP(SPC1)];            \Jump to expr on next line
  1780. if ATOM # OTHSYM then ERROR(29);
  1781. RATOM;
  1782. STATEMENT;                \'OTHER'
  1783. FIXUP(SPC2);
  1784. end;    \CASER
  1785.  
  1786.  
  1787.  
  1788. begin    \STATEMENT
  1789. case ATOM of
  1790. BEGSYM, ^[:
  1791.     begin
  1792.     RATOM;
  1793.     loop    begin
  1794.         if ATOM = ELSEYM then [ERROR(52); RATOM];
  1795.         if ATOM = OTHSYM then [ERROR(53); RATOM];
  1796.         STATEMENT;
  1797.         case ATOM of
  1798.           ^;:    RATOM;
  1799.           ENDSYM:    quit;
  1800.           ^]:    quit;
  1801.           EOF:    [ERROR(62); exit]
  1802.         other    \semi expected\ ERROR(41);
  1803.         end;
  1804.     RATOM;                \Read past the 'END'
  1805.     end;
  1806. CASEYM:    begin                \Case statement
  1807.     RATOM;
  1808.     if ATOM = OFSYM then CASER(\JOC\8)
  1809.     else    begin
  1810.         BOOLEXP;
  1811.         if FACTYP # INTEGER then ERROR(47);
  1812.         if ATOM # OFSYM then [ERROR(48); SKIPIT; return];
  1813.         STKLOD:= STKLOD+1;
  1814.         CASER(\CAJ\37);
  1815.         GEN(\DRP\40, 0, 0, 0);
  1816.         STKLOD:= STKLOD-1;
  1817.         end;
  1818.     end;
  1819. QUITYM:    begin                \Quit statement
  1820.     SDSP:= DSP;    \Don't interfere with the stack that GEN keeps
  1821.     for I:= SSTK, STKLOD-1 do GEN(\DRP\40, 0, 0, 0);
  1822.     if FIXCNT > QUITMAX then [ERROR(4); FIXCNT:= QUITMAX -1];
  1823.     GEN(\JMP\7, 0, 0, 7);    \This will be "FIXED UP" at end of 'LOOP'
  1824.     FIXES(FIXCNT):= PC -4;
  1825.     FIXCNT:= FIXCNT +1;
  1826.     DSP:= SDSP;
  1827.     RATOM;
  1828.     end;
  1829. IFSYM:    begin                \If statement
  1830.     RATOM;
  1831.     BOOLEXP;
  1832.     GEN(\JOC\8, 0, 0, 7);
  1833.     P3:= PC-4;
  1834.     if ATOM # THENYM then [ERROR(22); SKIPIT; return];
  1835.     RATOM;
  1836.     STATEMENT;
  1837.     if ATOM = ELSEYM then
  1838.         [GEN(\JMP\7, 0, 0, 7);
  1839.         P2:= PC -4;
  1840.         FIXUP(P3);
  1841.         P3:= P2;
  1842.         RATOM;
  1843.         STATEMENT];
  1844.     FIXUP(P3);
  1845.     end;
  1846. REPSYM:    [GEN(\BAL\$27, 0, 0, 0);    \Make sure the stack is balanced
  1847.     P2:= PC;            \Repeat statement
  1848.     repeat RATOM; STATEMENT until ATOM#^;;
  1849.     if ATOM # UNTSYM then [ERROR(28); SKIPIT; return];
  1850.     RATOM;
  1851.     BOOLEXP;
  1852.     GEN(\JOC\8, 0, P2, 7)];
  1853. WHILYM:    [RATOM;                \While statement
  1854.     GEN(\BAL\$27, 0, 0, 0);        \Make sure the stack is balanced
  1855.     P2:= PC;
  1856.     BOOLEXP;
  1857.     GEN(\JOC\8, 0, 0, 7);
  1858.     P3:= PC-4;
  1859.     if ATOM # DOSYM then [ERROR(23); SKIPIT; return];
  1860.     RATOM;
  1861.     STATEMENT;
  1862.     GEN(\JMP\7, 0, P2, 7);
  1863.     FIXUP(P3)];
  1864. RETSYM:    begin                \Return statement
  1865.     RATOM;
  1866.     if ATOM#ELSEYM & ATOM#OTHSYM & ATOM#^; & ATOM#^] &
  1867.         ATOM#ENDSYM & ATOM#UNTSYM then    \Store the returned
  1868.         [BOOLEXP;            \ value in "global 0"
  1869.         GEN(if FACTYP=INTEGER then\STO\3 else \FSTO\$2B, 0, -1, 10)];
  1870.                     \Return function values in D0 (= -1)
  1871.     SDSP:= DSP;
  1872.     \Don't interfere with GEN which keeps track of the p-stack pointer
  1873.     for I:= 0, STKLOD-1 do GEN(\DRP\40, 0, 0, 0);
  1874.     GEN(\RET\$06, LEVEL, 0, 0);
  1875.     DSP:= SDSP;
  1876.     end;
  1877. LOOPYM:    begin                \Loop statement
  1878.     SFIXS:= FIXCNT;
  1879.     RATOM;
  1880.     GEN(\BAL\$27, 0, 0, 0);        \Make sure the stack is balanced
  1881.     P2:= PC;
  1882.     SSTATEMENT(STKLOD);
  1883.     if LASTOP#\JMP\7 then GEN(\JMP\7, 0, P2, 7);
  1884.     while FIXCNT>SFIXS do        \"FIX UP" the jumps for the 'QUIT'S
  1885.         [FIXCNT:= FIXCNT-1; FIXUP(FIXES(FIXCNT))];
  1886.     end;
  1887. FORSYM:    begin                \For statement
  1888.     RATOM;
  1889.     if ATYPE # IDENTIFIER then [ERROR(33); SKIPIT; return];
  1890.     LOOKUP;
  1891.     if IDTYPE = UNDEF then ERROR(10)
  1892.         else if IDTYPE # INVAR then ERROR(33);
  1893.     SLEV:= LEV; SVAL:= VAL;
  1894.     RATOM;
  1895.     if ATOM # GETSYM then [ERROR(21); SKIPIT; return];
  1896.     RATOM;
  1897.     BOOLEXP;
  1898.     if FACTYP # INTEGER then ERROR(47);
  1899.     GEN(\STO\3, SLEV, SVAL, 10);
  1900.     if ATOM # ^, then [ERROR(24); SKIPIT; return];
  1901.     RATOM;
  1902.     BOOLEXP;
  1903.     if FACTYP # INTEGER then ERROR(47);
  1904.     if ATOM # DOSYM then [ERROR(23); SKIPIT; return];
  1905.     GEN(\JMP\7, 0, 0, 7);
  1906.     P2:= PC -4;
  1907.     GEN(\BAL\$27, 0, 0, 0);        \Make sure the stack is balanced
  1908.     P3:= PC;
  1909.     RATOM;
  1910.     STKLOD:= STKLOD +1;
  1911.     STATEMENT;
  1912.     STKLOD:= STKLOD -1;
  1913.     GEN(\INC\25, SLEV, SVAL, 10);
  1914.     FIXUP(P2);
  1915.     GEN(\LOD\1, SLEV, SVAL, 10);
  1916.     GEN(\FOR\24, 0, P3, 7);
  1917.     end;
  1918. EXITYM:    begin
  1919.     RATOM;
  1920.     GEN(\EXIT\0, LEVEL, 0, 0);    \'EXIT' statement
  1921.     end;
  1922. ELSEYM:    [];                \Null statement
  1923. OTHSYM:    [];
  1924. ^;:    [];
  1925. ^]:    [];
  1926. ENDSYM:    [];
  1927. UNTSYM:    [];
  1928. EOF:    []                \(This is mostly an academic point)
  1929. other    ASSIGN;
  1930. end;    \STATEMENT
  1931.  
  1932.  
  1933.  
  1934. begin    \SSTATEMENT
  1935. \Trick to adjust stack (with DRP's) when a 'QUIT' is in a 'CASE' statement.
  1936. STATEMENT;
  1937. end;
  1938.  
  1939. \----------------------------------------------------------------------
  1940.  
  1941. proc    PROCEDURE;
  1942. int    P1, DX,        \Heap space requirement counter
  1943.     I,
  1944.     SNOSYM,
  1945.     FPBASE,        \PC at end of declarations
  1946.     FPROCNT;    \Count of pending forward procedures
  1947.  
  1948.  
  1949.  
  1950. proc    CODDEC;        \Declare intrinsic names
  1951. int    SID;
  1952. begin
  1953. SID:= ININT;                \Default is integer intrinsic
  1954. RATOM;
  1955. if ATOM = REALYM then [SID:= RLINT; RATOM]
  1956.     else if ATOM = INTSYM then RATOM;
  1957. if ATYPE # IDENTIFIER then ERROR(45);
  1958. while ATYPE = IDENTIFIER do
  1959.     [RATOM;
  1960.     if ATOM # ^= then ERROR(40);
  1961.     RATOM;
  1962.     GETCON; if FACTYP # INTEGER then ERROR(47);
  1963.     if IATOM<0 ! IATOM>127 then ERROR(7);
  1964.     INSERT(SID, LEVEL, IATOM);
  1965.     RATOM;
  1966.     if ATOM = ^, then RATOM];
  1967. if ATOM # ^; then ERROR(41) else RATOM;
  1968. end;    \CODDEC
  1969.  
  1970.  
  1971.  
  1972. proc    CONDEC;        \Declare constant names
  1973. int    CNTR, SSNO;
  1974. begin
  1975. RATOM;
  1976. CNTR:= 0;
  1977. if ATYPE # IDENTIFIER then ERROR(45);
  1978. while ATYPE = IDENTIFIER do
  1979.     begin
  1980.     RATOM;
  1981.     if ATOM # ^= then [INSERT(INCON, LEVEL, CNTR); CNTR:= CNTR+1]
  1982.     else    begin
  1983.         SSNO:= NOSYM;
  1984.         INSERT(INCON, LEVEL, NORLSY);    \Insert ID now
  1985.         RATOM;                \ fix up parms later
  1986.         GETCON;
  1987.         if FACTYP = INTEGER then SYMVAL(SSNO):= IATOM
  1988.         else            \FACTYP = REAL
  1989.             [SYMTYP(SSNO):= RLCON;
  1990.             if NORLSY >= RLMAX then
  1991.                 [ERROR(2); NORLSY:= RLMAX-1];
  1992.             RLTBL(NORLSY):= RLATOM;
  1993.             NORLSY:= NORLSY +1];
  1994.         RATOM;
  1995.         end;
  1996.     if ATOM = ^, then RATOM;
  1997.     end;
  1998. if ATOM # ^; then ERROR(41) else RATOM;
  1999. end;    \CONDEC
  2000.  
  2001.  
  2002.  
  2003. proc    VARDEC(TYPE);  \Declare variables: 'INT', 'REAL' & 'ADDR'
  2004. int    TYPE;
  2005. begin
  2006. RATOM;
  2007. if ATYPE # IDENTIFIER then ERROR(45);
  2008. while ATYPE = IDENTIFIER do
  2009.     [INSERT(TYPE,  LEVEL,  DX);
  2010.     DX:= DX + (if TYPE=RLVAR then RLSIZE else INTSIZE);
  2011.     RATOM;
  2012.     if ATOM = ^, then RATOM];
  2013. if ATOM # ^; then ERROR(41) else RATOM;
  2014. end;    \VARDEC
  2015.  
  2016.  
  2017.  
  2018. proc    RVARDEC;    \Declare register variables: INT, REAL & ADDR
  2019. int    I, SNOSYM;    \E.G: 'REG' 'INT' FROG, AARDVARK, PIG;
  2020. begin
  2021. SNOSYM:= NOSYM;
  2022. RATOM;
  2023. case ATOM of
  2024.   INTSYM: VARDEC(INVAR);
  2025.   ADRSYM: VARDEC(ADDRVAR);
  2026.   REALYM: VARDEC(RLVAR)
  2027. other ERROR(55);            \Variable declaration expected
  2028.  
  2029. \Fix symbol table entries to indicate register variables. This gyration
  2030. \ is required because of argument passing. Each register variable has a
  2031. \ corresponding normal memory variable which might be passed an argument.
  2032. \ The level entry in the symbol table (SYMLEV) is meaningless for register
  2033. \ variables, so it is used to hold the offset of the corresponding memory
  2034. \ variable.
  2035.  
  2036. for I:= SNOSYM, NOSYM-1 do
  2037.     begin
  2038.     SYMLEV(I):= SYMVAL(I);        \Get offset of memory variable
  2039.     SYMVAL(I):= -PSTOP;        \Get register from top of p-stack
  2040.     PSTOP:= PSTOP -1;        \ -8 is D7, etc.
  2041.     if PSTOP < 3 then ERROR(8);    \Too many register variables
  2042.     end;
  2043. end;    \RVARDEC
  2044.  
  2045.  
  2046.  
  2047. proc    EXTDEC;        \Declare external procedures
  2048. int    SID;
  2049. begin
  2050. SID:= INEXT;                \Default is integer external procedure
  2051. RATOM;
  2052. if ATOM = REALYM then [SID:= RLEXT; RATOM]
  2053. else if ATOM = INTSYM then RATOM;
  2054. if ATYPE # IDENTIFIER then ERROR(45);
  2055. while ATYPE = IDENTIFIER do
  2056.     [RATOM;
  2057.     if ATOM # ^= then ERROR(40);
  2058.     RATOM;
  2059.     GETCON; if FACTYP # INTEGER then ERROR(47);
  2060.     INSERT(SID, LEVEL, IATOM);
  2061.     RATOM;
  2062.     if ATOM = ^, then RATOM];
  2063. if ATOM # ^; then ERROR(41) else RATOM;
  2064. end;    \EXTDEC
  2065.  
  2066.  
  2067.  
  2068. proc    FPRDEC;        \Declare forward referenced procedures
  2069. int    SID;
  2070. begin
  2071. SID:= INFPROC;                \Default is integer forward procedure
  2072. RATOM;
  2073. if ATOM = REALYM then [SID:= RLFPROC; RATOM]
  2074. else if ATOM = INTSYM then RATOM;
  2075. if ATYPE # IDENTIFIER then ERROR(45);
  2076. while ATYPE = IDENTIFIER do
  2077.     [RATOM;
  2078.     GEN(\JMP\7, 0, PC, 7);        \Jump to self ("FIXED UP" later)
  2079.     INSERT(SID, LEVEL, PC-4);
  2080.     FPROCNT:= FPROCNT+1;
  2081.     if ATOM = ^, then RATOM];
  2082. if ATOM # ^; then ERROR(41) else RATOM;
  2083. end;    \FPRDEC
  2084.  
  2085.  
  2086.  
  2087. proc    EPRDEC;        \Declare external procedures
  2088. int    SID;
  2089. begin
  2090. SID:= INEPROC;                \Default is integer external procedure
  2091. RATOM;
  2092. if ATOM = REALYM then [SID:= RLEPROC; RATOM]
  2093. else if ATOM = INTSYM then RATOM;
  2094. if ATYPE # IDENTIFIER then ERROR(45);
  2095. while ATYPE = IDENTIFIER do
  2096.     [RATOM;
  2097.     GEN(\JMP\7, 0, PC, 64);        \Jump to self "FIXED UP" by 'LINK' (%)
  2098.     INSERT(SID, LEVEL, PC-6);
  2099.     if ATOM = ^, then RATOM];
  2100. if ATOM # ^; then ERROR(41) else RATOM;
  2101. end;    \EPRDEC
  2102.  
  2103.  
  2104.  
  2105. proc    PROCDEC;    \Declare procedure names
  2106. int    SNOSYM, HASH, I, K, SID, SNORL, SPSTOP, SPSTOP0;
  2107. begin
  2108. SID:= INPROC;                \Typed procedure (for functions)
  2109. RATOM;
  2110. if ATOM = REALYM then [SID:= RLPROC; RATOM]
  2111. else if ATOM = INTSYM then RATOM;
  2112. if ATYPE # IDENTIFIER then ERROR(45) else LOOKUP;
  2113. if IDTYPE=INFPROC ! IDTYPE=RLFPROC then
  2114.     \Procedure has been previously declared by a 'FPROC' or 'FFUNCT'
  2115.     [if LEVEL#LEV then ERROR(65);
  2116.     FIXUP(VAL);            \('FPROC' & 'PROC' must be same scope)
  2117.     SYMVAL(SYMNUM):= PC;
  2118.     SYMTYP(SYMNUM):= if IDTYPE = INFPROC then INPROC else RLPROC;
  2119.     \(Speed up things a little by changing forward proc to normal proc)
  2120.     if SID # SYMTYP(SYMNUM) then \mixed mode\ ERROR(46);
  2121.     if VAL >= FPBASE then FPROCNT:= FPROCNT-1]
  2122. else if IDTYPE=INEPROC ! IDTYPE=RLEPROC then
  2123.     \Procedure has been previously declared by an 'EPROC' or 'EFUNCT'
  2124.     [if LEVEL # LEV then ERROR(65);    \('EPROC' & 'PROC' must be same scope)
  2125.     SYMVAL(SYMNUM):= PC;
  2126.     SYMTYP(SYMNUM):= if IDTYPE = INEPROC then INPROC else RLPROC;
  2127.     \(Speed up things a little by changing external proc to normal proc.
  2128.     \ This also prevents flagging a multiple-definition error)
  2129.     if SID # SYMTYP(SYMNUM) then \mixed mode\ ERROR(46)]
  2130. else INSERT(SID, LEVEL, PC);
  2131.  
  2132. LEVEL:= LEVEL+1; if LEVEL>4 then ERROR(5);
  2133.                     \Eat the argument list as a comment
  2134. while CHAR#^; & CHAR#\CR\$0D do GETCH;    \Special comment stops on CR
  2135. if CHAR # ^; then ERROR(41);
  2136. GETCH; RATOM;
  2137.  
  2138. SNOSYM:= NOSYM; SNORL:= NORLSY; SPSTOP:= PSTOP; SPSTOP0:= PSTOP0;
  2139. PROCEDURE;
  2140. if ATOM # ^; then ERROR(41) else RATOM;
  2141.  
  2142. while NOSYM > SNOSYM do        \Restore symbol table to previous level
  2143.     \I.e. remove the identifiers which were local to this procedure
  2144.     [NOSYM:= NOSYM-1;
  2145.     HASH:= 0; K:= NOSYM;
  2146.     for I:= 0, SIGCHAR-1 do
  2147.         [HASH:= HASH +SYMBOL(K); K:= K +SYMAX];
  2148.     BOXES(HASH &$FF):= SYMPNT(NOSYM)];
  2149. NORLSY:= SNORL;
  2150. PSTOP:= SPSTOP;
  2151. PSTOP0:= SPSTOP0;
  2152. LEVEL:= LEVEL-1;
  2153. end;    \PROCDEC
  2154.  
  2155.  
  2156.  
  2157. begin    \PROCEDURE
  2158. DX:= 0;
  2159. SNOSYM:= NOSYM;
  2160. DSP:= 1;                \Init pseudo stack pointer
  2161. FPSP:= 1;                \Init floating point p-stack pointer
  2162. PSTOP0:= PSTOP;                \(For generating HPI and RET)
  2163. GEN(\JMP\7, 0, 0, 7);
  2164. P1:= PC -4;
  2165. loop    case ATOM of
  2166.       REGSYM: RVARDEC;
  2167.       INTSYM: VARDEC(INVAR);
  2168.       ADRSYM: VARDEC(ADDRVAR);
  2169.       REALYM: VARDEC(RLVAR);
  2170.       CODSYM: CODDEC;
  2171.       EXTNYM: EXTDEC;
  2172.       DEFSYM: CONDEC;
  2173.       EPRSYM, EFUNYM:
  2174.         if LEVEL = 0 then EPRDEC else [ERROR(68); SKIPIT]
  2175.     other    quit;
  2176. FPROCNT:= 0;
  2177. FPBASE:= PC;
  2178. loop    case ATOM of
  2179.       LNKSYM:
  2180.         [if LEVEL # 0 then ERROR(68);
  2181.         CLOSEOBJ;
  2182.         CHOUT3(^%);
  2183.         RATOM;
  2184.         case ATOM of PROCYM, FUNSYM: PROCDEC
  2185.         other ERROR(67)];
  2186.       PROCYM, FUNSYM:
  2187.         PROCDEC;
  2188.       FPRSYM, FFUNYM:
  2189.         FPRDEC            \'FPROC' cannot precede a 'DEF'
  2190.     other    quit;
  2191.  
  2192. \If there is nothing to jump over then eliminate the jump
  2193. if PC = P1+4 then GENPC(-4) else FIXUP(P1);
  2194.  
  2195. GEN(\HPI\9, LEVEL, DX, 2);        \Reserve space for local variables
  2196. if DX >= $8000 then \too many variables\ ERROR(1);
  2197.  
  2198. \Generate code to initialize any register variables in case they are used
  2199. \ to receive arguments:
  2200. for I:= SNOSYM, NOSYM-1 do
  2201.     if SYMVAL(I) < 0 then        \It might be a register variable
  2202.     case SYMTYP(I) of INVAR, ADDRVAR:
  2203.         [GEN(\LOD\1, LEVEL, SYMLEV(I), 10);    \SYMLEV holds offset to memory
  2204.         GEN(\STO\3, 0, SYMVAL(I), 10)];    \SYMVAL is a register (-8 = D7)
  2205.     RLVAR: []            \$$$
  2206.     other;
  2207.  
  2208. SSTATEMENT(STKLOD);            \(STKLOD will always be zero here)
  2209. GEN(\RET\6, LEVEL, 0, 0);
  2210. if FIXCNT # 0 then \some 'QUIT's not in a 'LOOP'\ ERROR(60);
  2211. if FPROCNT # 0 then \unresolved fwd references\ ERROR(66);
  2212. end;    \PROCEDURE
  2213.  
  2214. \======================================================================
  2215.  
  2216. begin    \MAIN: Display title and initialize
  2217. IDENT:= RESERVE(SIGCHAR);
  2218. FIXES:= RESERVE(QUITMAX *INTSIZE);
  2219. SYMBOL:= RESERVE(SIGCHAR *SYMAX);    \Symbol table
  2220. SYMTYP:= RESERVE(SYMAX);
  2221. SYMVAL:= RESERVE(SYMAX *INTSIZE);
  2222. SYMLEV:= RESERVE(SYMAX);
  2223. SYMPNT:= RESERVE(SYMAX *INTSIZE);
  2224. BOXES:= RESERVE(256 *INTSIZE);        \Hash table
  2225. \RLTBL:= RLRES(RLMAX);                    *** DEBUG ***  $$$
  2226. HEXDIGIT:= "0123456789ABCDEF";
  2227. ERRBUF:= RESERVE($100);
  2228. OBJBUF:= RESERVE(8 *INTSIZE);
  2229.  
  2230. DEFAULT:= [7];                \Default listing device no.
  2231. TEXT(TV, "-- XPL0 COMPILER, VER 5.7-68Kx15 --
  2232.  
  2233. ");
  2234. loop    begin
  2235.     TEXT(TV, "CHANGE DEFAULTS (N/Y)? ");
  2236.     if (CHIN(KB)!$20) # ^y then quit;
  2237.     TEXT(TV, "LISTING DEVICE NUMBER? ");
  2238.     DEFAULT(0):= INTIN(KB);
  2239.     OPENI(KB);
  2240.     end;
  2241. LSTDEV:= DEFAULT(0);
  2242. OPENO(LSTDEV);
  2243. OPENI(3); OPENO(3);
  2244.  
  2245. TEXT(TV, "COMPILING...
  2246. ");
  2247.  
  2248. PC:= 0;
  2249. CHOUT3(^;); HEX4OUT(PC);
  2250. OPENOBJ;
  2251.  
  2252. ERRPTR:= 0;                \Initialize some stuff
  2253. for II:= 0, $FF do ERRBUF(II):= 0;
  2254. \CASEIN:= false;
  2255. LEVEL:= 0;    PSTOP:= 8;    FPSTOP:= 4;
  2256. LASTOP:= -1;    STKLOD:= 0;    NOSYM:= 0;    NORLSY:= 0;    FIXCNT:= 0;
  2257. for II:= 0, 255 do BOXES(II):= \empty\ -1;    \Empty the symbol table
  2258. ERRCNT:= 0;
  2259. GETCH; RATOM;
  2260.  
  2261. PROCEDURE;                \Compile main procedure (the program)
  2262. while ATOM = ^; do RATOM;
  2263. if ATOM # EOF then \more code after end\ [ERROR(61); PROCEDURE];
  2264.  
  2265. if LSTDEV = TV then CRLF(TV);
  2266. TEXT(TV, "LENGTH (BYTES):  "); INTOUT(TV, PC); TEXT(TV, "
  2267. ERRORS DETECTED: "); INTOUT(TV, ERRCNT); CRLF(TV);
  2268. CLOSEOBJ;
  2269. if ERRCNT = 0 then CLOSE(3);
  2270. CLOSE(LSTDEV);
  2271. end;    \MAIN
  2272. V, "
  2273. ERRORS DETECTED: "); INTOUT(TV, ERRCNT); CRLF(TV);
  2274. CL